Skip to content
GitLab
Commit a42774b8 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

bug fix (changed syntax tree)

parent 3583d352
Hide whitespace changes
Inline Side-by-side
frontend/check.icl
View file @ a42774b8
......@@ -1402,7 +1402,7 @@ where
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(var_binds, expr_heap) = build_binds vars [] expr_heap
let_binds = [{ bind_src = expr, bind_dst = hd vars }:var_binds]
= (Let {let_strict = cIsNotStrict, let_binds = let_binds, let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap)
= (Let {let_strict_binds = [], let_lazy_binds = let_binds, let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap)
where
build_binds [var] accu expr_heap
= (accu, expr_heap)
......@@ -1673,7 +1673,9 @@ buildLetExpression [] is_strict expr expr_heap
= (expr, expr_heap)
buildLetExpression binds is_strict expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Let {let_strict = is_strict, let_binds = binds, let_expr = expr, let_info_ptr = let_expr_ptr }, 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)
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, var_env, {ps_fun_defs,ps_var_heap}, e_info, cs)
......@@ -2063,14 +2065,14 @@ where
| bind_dst == fv_info_ptr
# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (Let { let_strict = cIsStrict, let_binds = [
-> (Let { let_lazy_binds = [], let_strict_binds = [
{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr },
bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}],
let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs)
# (var_expr_ptr1, expr_heap) = newPtr EI_Empty expr_heap
(var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap
(let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (Let { let_strict = cIsStrict, let_binds = [
-> (Let { let_lazy_binds = [], let_strict_binds = [
{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 },
bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }},
{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 },
......@@ -2081,7 +2083,7 @@ where
-> (result_expr, var_store, expr_heap, opt_dynamics, cs)
# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (Let { let_strict = cIsStrict, let_binds =
-> (Let { let_lazy_binds = [], let_strict_binds =
[{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr },
bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}],
let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs)
......@@ -2122,7 +2124,7 @@ where
(var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap
(let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 },
Let { let_strict = cIsNotStrict, let_binds =
Let { let_strict_binds = [], let_lazy_binds =
[{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 },
bind_dst = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }}],
let_expr = result_expr, let_info_ptr = let_expr_ptr}, expr_heap)
......
frontend/convertDynamics.icl
View file @ a42774b8
......@@ -118,12 +118,13 @@ where
# (expr, ci) = convertDynamics cinp bound_vars default_expr expr ci
(exprs, ci) = convertDynamics cinp bound_vars default_expr exprs ci
= (expr @ exprs, ci)
convertDynamics cinp bound_vars default_expr (Let letje=:{let_binds, let_expr,let_info_ptr}) ci
convertDynamics cinp bound_vars default_expr (Let letje=:{let_strict_binds, let_lazy_binds, let_expr,let_info_ptr}) ci
# (let_types, ci) = determine_let_types let_info_ptr ci
bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_binds ] let_types bound_vars
(let_binds, ci) = convertDynamics cinp bound_vars default_expr let_binds ci
(let_expr, ci) = convertDynamics cinp bound_vars default_expr let_expr ci
= (Let { letje & let_binds = let_binds, let_expr = let_expr}, ci)
bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
(let_strict_binds, ci) = convertDynamics cinp bound_vars default_expr let_strict_binds ci
(let_lazy_binds, ci) = convertDynamics cinp bound_vars default_expr let_lazy_binds ci
(let_expr, ci) = convertDynamics cinp bound_vars default_expr let_expr ci
= (Let { letje & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr}, ci)
where
determine_let_types let_info_ptr ci=:{ci_expr_heap}
# (EI_LetType let_types, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap
......@@ -183,12 +184,12 @@ where
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr }, ci)
_ # (let_info_ptr, ci) = let_ptr ci
-> ( Let { let_strict = False,
let_binds = let_binds,
let_expr = App { app_symb = twoTuple_symb,
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr },
let_info_ptr = let_info_ptr}, ci)
-> ( Let { let_strict_binds = [],
let_lazy_binds = let_binds,
let_expr = App { app_symb = twoTuple_symb,
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr },
let_info_ptr = let_info_ptr}, ci)
convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
= convertTypecode cinp type_code ci
convertDynamics cinp bound_vars default_expr EE ci
......@@ -283,7 +284,7 @@ convertDynamicPatterns cinp bound_vars {case_expr, case_guards = DynamicPatterns
(addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
(binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
(let_info_ptr, ci) = let_ptr ci
= (Let {let_strict = False, let_binds = [ dt_bind : binds ], let_expr = expr, let_info_ptr = let_info_ptr}, ci)
= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ], let_expr = expr, let_info_ptr = let_info_ptr}, ci)
where
convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
-> (Env Expression FreeVar, Expression, *ConversionInfo)
......@@ -320,8 +321,8 @@ where
(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 },
let_expr = Let { let_strict_binds = [],
let_lazy_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr },
bind_dst = unify_result_fv },
{ bind_src = TupleSelect twotuple 0 (Var unify_result_var),
bind_dst = unify_bool_fv } : let_binds
......
frontend/convertcases.icl
View file @ a42774b8
......@@ -42,13 +42,16 @@ where
instance convertCases Let
where
convertCases bound_vars group_index common_defs lad=:{let_binds,let_expr,let_info_ptr} ci=:{ci_expr_heap}
convertCases bound_vars group_index common_defs lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr} ci=:{ci_expr_heap}
# (let_info, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap
ci = { ci & ci_expr_heap = ci_expr_heap }
= case let_info of
EI_LetType let_type
# ((let_binds,let_expr), ci) = convertCases (addLetVars let_binds let_type bound_vars) group_index common_defs (let_binds,let_expr) ci
-> ({ lad & let_binds = let_binds, let_expr = let_expr }, ci)
# bound_vars = addLetVars (let_strict_binds ++ let_lazy_binds) let_type bound_vars
# (let_strict_binds, ci) = convertCases bound_vars group_index common_defs let_strict_binds ci
# (let_lazy_binds, ci) = convertCases bound_vars group_index common_defs let_lazy_binds ci
# (let_expr, ci) = convertCases bound_vars group_index common_defs let_expr ci
-> ({ lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, ci)
_
-> abort "convertCases [Let] (convertcases 53)" // <<- let_info
......@@ -483,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 ==> ("convert_function", fun_def.fun_symb)) (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)
......@@ -635,12 +638,13 @@ where
(sd_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs sd_type imported_types conses type_heaps var_heap
= (imported_types, conses, type_heaps, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type))
convertRootExpression bound_vars group_index common_defs default_ptr (Let lad=:{let_binds,let_expr,let_info_ptr}) ci=:{ci_expr_heap}
convertRootExpression bound_vars group_index common_defs default_ptr (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) ci=:{ci_expr_heap}
# (EI_LetType let_type, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap
bound_vars = addLetVars let_binds let_type bound_vars
(let_binds, ci) = convertCases bound_vars group_index common_defs let_binds { ci & ci_expr_heap = ci_expr_heap }
(let_expr, ci) = convertRootExpression bound_vars group_index common_defs default_ptr let_expr ci
= (Let { lad & let_binds = let_binds, let_expr = let_expr }, ci)
bound_vars = addLetVars (let_strict_binds ++ let_lazy_binds) let_type bound_vars
(let_strict_binds, ci) = convertCases bound_vars group_index common_defs let_strict_binds { ci & ci_expr_heap = ci_expr_heap }
(let_lazy_binds, ci) = convertCases bound_vars group_index common_defs let_lazy_binds ci
(let_expr, ci) = convertRootExpression bound_vars group_index common_defs default_ptr let_expr ci
= (Let { lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, ci)
convertRootExpression bound_vars group_index common_defs default_ptr (Case kees=:{case_expr, case_guards, case_default, case_info_ptr}) ci
= case case_guards of
BasicPatterns BT_Bool patterns
......@@ -760,7 +764,7 @@ where
{ cp_info & cp_free_vars = [ (var_info_ptr, type) : cp_info.cp_free_vars ],
cp_var_heap = cp_var_heap <:= (var_info_ptr, VI_FreeVar var_name new_info_ptr 1 type) })
_
-> abort "copy [BoundVar] (convertcases, 612)" // <<- (var_info ---> (var_name, ptrToInt var_info_ptr))
-> abort "copy [BoundVar] (convertcases, 612)" <<- (var_info ---> (var_name, ptrToInt var_info_ptr))
instance copy Expression
where
......@@ -773,10 +777,13 @@ where
copy (fun_expr @ exprs) cp_info
# ((fun_expr, exprs), cp_info) = copy (fun_expr, exprs) cp_info
= (fun_expr @ exprs, cp_info)
copy (Let lad=:{let_binds,let_expr}) cp_info=:{cp_var_heap, cp_local_vars}
# (cp_local_vars, cp_var_heap) = foldSt bind_let_var let_binds (cp_local_vars, cp_var_heap)
# ((let_binds,let_expr), cp_info) = copy (let_binds,let_expr) {cp_info & cp_var_heap = cp_var_heap, cp_local_vars = cp_local_vars }
= (Let {lad & let_expr = let_expr, let_binds = let_binds }, cp_info)
copy (Let lad=:{let_strict_binds,let_lazy_binds, let_expr}) cp_info=:{cp_var_heap, cp_local_vars}
# (cp_local_vars, cp_var_heap) = foldSt bind_let_var let_strict_binds (cp_local_vars, cp_var_heap)
# (cp_local_vars, cp_var_heap) = foldSt bind_let_var let_lazy_binds (cp_local_vars, cp_var_heap)
# (let_strict_binds, cp_info) = copy let_strict_binds {cp_info & cp_var_heap = cp_var_heap, cp_local_vars = cp_local_vars }
# (let_lazy_binds, cp_info) = copy let_lazy_binds cp_info
# (let_expr, cp_info) = copy let_expr cp_info
= (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, cp_info)
where
bind_let_var {bind_dst} (local_vars, var_heap)
= ([bind_dst : local_vars], var_heap <:= (bind_dst.fv_info_ptr, VI_LocalVar))
......@@ -977,7 +984,8 @@ where
= weightedRefCount dcl_functions common_defs depth app rc_info
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_binds,let_expr, let_info_ptr}) rc_info=:{rc_var_heap}
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 }
(let_info, rc_expr_heap) = readPtr let_info_ptr rc_info.rc_expr_heap
rc_info = { rc_info & rc_expr_heap = rc_expr_heap }
......@@ -1270,24 +1278,22 @@ where
distributeLets depth (TupleSelect tuple_symbol arg_nr expr) dl_info
# (expr, dl_info) = distributeLets depth expr dl_info
= (TupleSelect tuple_symbol arg_nr expr, dl_info)
distributeLets depth (Let lad=:{let_binds,let_expr,let_strict,let_info_ptr}) dl_info=:{di_expr_heap,di_var_heap}
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
ok = case let_info of
EI_LetTypeAndRefCounts let_type ref_counts -> True
x -> abort ("abort [distributeLets (EI_LetTypeAndRefCounts)]") // ->> x)
| ok
# (EI_LetTypeAndRefCounts let_type ref_counts) = let_info
di_var_heap = set_let_expression_info depth let_strict let_binds ref_counts 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 }
= (let_expr, foldSt (distribute_lets_in_non_distributed_let depth) let_binds dl_info)
= undef
# (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
(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
dl_info = foldSt (distribute_lets_in_non_distributed_let depth) let_lazy_binds dl_info
= (let_expr, dl_info)
where
set_let_expression_info depth let_strict [{bind_src,bind_dst}:binds][ref_count:ref_counts][type:types] var_heap
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
lei = { lei_count = ref_count, lei_depth = depth, lei_strict = let_strict, /* lei_moved = False, */
lei_var = { bind_dst & fv_info_ptr = new_info_ptr }, lei_expression = bind_src, lei_type = type, lei_status = LES_Untouched }
= set_let_expression_info depth let_strict binds ref_counts types (var_heap <:= (bind_dst.fv_info_ptr, VI_LetExpression lei))
set_let_expression_info depth let_strict [] _ _ var_heap
= set_let_expression_info depth binds ref_counts types (var_heap <:= (bind_dst.fv_info_ptr, VI_LetExpression lei))
set_let_expression_info depth [] _ _ var_heap
= var_heap
distribute_lets_in_non_distributed_let depth {bind_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap}
......@@ -1422,18 +1428,10 @@ 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
= (let_expr, (var_heap, expr_heap))
# (let_info_ptr, expr_heap) = newPtr (EI_LetType lazy_binds_types) expr_heap
= (Let { let_binds = lazy_binds, let_strict = cIsNotStrict, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap))
| isEmpty lazy_binds
# (let_info_ptr, expr_heap) = newPtr (EI_LetType strict_bind_types) expr_heap
= (Let { let_binds = strict_binds, let_strict = cIsStrict, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap))
# (strict_let_info_ptr, expr_heap) = newPtr (EI_LetType strict_bind_types) expr_heap
(lazy_let_info_ptr, expr_heap) = newPtr (EI_LetType lazy_binds_types) expr_heap
= (Let { let_binds = strict_binds, let_strict = cIsStrict, let_info_ptr = strict_let_info_ptr, let_expr =
Let { let_binds = lazy_binds, let_strict = cIsNotStrict, let_info_ptr = lazy_let_info_ptr, let_expr = let_expr }}, (var_heap, expr_heap))
| isEmpty strict_binds && 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))
where
build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap)
......
frontend/explicitimports.icl
View file @ a42774b8
......@@ -788,8 +788,8 @@ instance consequences InstanceType
consequences {it_types, it_context} = consequences it_types++consequences it_context
instance consequences Let
where consequences { let_binds, let_expr }
= consequences let_expr++(flatten [consequences bind_src \\ {bind_src}<-let_binds] )
where consequences { let_strict_binds, let_lazy_binds, let_expr }
= consequences let_expr++(flatten [consequences bind_src \\ {bind_src}<-let_strict_binds ++ let_lazy_binds] )
instance consequences MemberDef
where
......
frontend/overloading.icl
View file @ a42774b8
......@@ -1018,9 +1018,11 @@ where
updateExpression group_index type_contexts (expr @ exprs) ui
# ((expr, exprs), ui) = updateExpression group_index type_contexts (expr, exprs) ui
= (expr @ exprs, ui)
updateExpression group_index type_contexts (Let lad=:{let_binds, let_expr}) ui
# ((let_binds, let_expr), ui) = updateExpression group_index type_contexts (let_binds, let_expr) ui
= (Let {lad & let_binds = let_binds, let_expr = let_expr}, ui)
updateExpression group_index type_contexts (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) ui
# (let_lazy_binds, ui) = updateExpression group_index type_contexts let_lazy_binds ui
# (let_strict_binds, ui) = updateExpression group_index type_contexts let_strict_binds ui
# (let_expr, ui) = updateExpression group_index type_contexts let_expr ui
= (Let {lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}, ui)
updateExpression group_index type_contexts (Case kees=:{case_expr,case_guards,case_default}) ui
# ((case_expr,(case_guards,case_default)), ui) = updateExpression group_index type_contexts (case_expr,(case_guards,case_default)) ui
= (Case { kees & case_expr = case_expr, case_guards = case_guards, case_default = case_default }, ui)
......
frontend/refmark.icl
View file @ a42774b8
......@@ -95,19 +95,20 @@ where
= refMark free_vars NotASelector app_args var_heap
refMark free_vars sel (fun @ args) var_heap
= refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap)
refMark free_vars sel (Let {let_strict,let_binds,let_expr}) var_heap
# let_vars = [ bind_dst \\ {bind_dst} <- let_binds ]
new_free_vars = [ let_vars : free_vars]
| let_strict
# (observing, var_heap) = binds_are_observing let_binds var_heap
refMark free_vars sel (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap
| isEmpty let_lazy_binds
# new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ] : free_vars]
# (observing, var_heap) = binds_are_observing let_strict_binds var_heap
| observing
# var_heap = saveOccurrences free_vars var_heap
var_heap = refMark new_free_vars NotASelector let_binds var_heap
var_heap = refMark new_free_vars NotASelector let_strict_binds var_heap
var_heap = saveOccurrences new_free_vars var_heap
var_heap = refMark new_free_vars sel let_expr var_heap
= let_combine free_vars var_heap
= refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_binds var_heap)
# var_heap = foldSt bind_variable let_binds var_heap
= refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_strict_binds var_heap)
# new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars]
var_heap = foldSt bind_variable let_strict_binds var_heap
var_heap = foldSt bind_variable let_lazy_binds var_heap
= refMark new_free_vars sel let_expr var_heap
where
......
frontend/syntax.dcl
View file @ a42774b8
......@@ -1025,13 +1025,21 @@ cIsNotStrict :== False
, case_ident :: !Optional Ident
, case_info_ptr :: !ExprInfoPtr
}
/*
:: Let =
{ let_strict :: !Bool
, let_binds :: !(Env Expression FreeVar)
, let_expr :: !Expression
, let_info_ptr :: !ExprInfoPtr
}
*/
:: Let =
{ let_strict_binds :: !Env Expression FreeVar
, let_lazy_binds :: !Env Expression FreeVar
, let_expr :: !Expression
, let_info_ptr :: !ExprInfoPtr
}
:: Conditional =
{ if_cond :: !Expression
......
frontend/syntax.icl
View file @ a42774b8
......@@ -964,13 +964,12 @@ cIsNotStrict :== False
}
:: Let =
{ let_strict :: !Bool
, let_binds :: !(Env Expression FreeVar)
, let_expr :: !Expression
, let_info_ptr :: !ExprInfoPtr
{ let_strict_binds :: !Env Expression FreeVar
, let_lazy_binds :: !Env Expression FreeVar
, let_expr :: !Expression
, let_info_ptr :: !ExprInfoPtr
}
:: DynamicExpr =
{ dyn_expr :: !Expression
, dyn_opt_type :: !Optional DynamicType
......@@ -1332,7 +1331,7 @@ where
// = file <<< app_symb <<< ' ' <<< app_args
= file <<< app_symb <<< " <" <<< ptrToInt app_info_ptr <<< "> " <<< app_args
(<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')'
(<<<) file (Let {let_info_ptr, let_binds, let_expr}) = write_binds (file <<< "let" <<< '\n') let_binds <<< "in\n" <<< let_expr
(<<<) 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
where
write_binds file []
= file
......
frontend/trans.icl
View file @ a42774b8
......@@ -220,7 +220,8 @@ instance consumerRequirements Expression where
# (cc_fun, _, ai) = consumerRequirements fun_expr common_defs ai
ai_class_subst = unifyClassifications cActive cc_fun ai.ai_class_subst
= consumerRequirements exprs common_defs { ai & ai_class_subst = ai_class_subst }
consumerRequirements (Let {let_binds,let_expr}) common_defs ai=:{ai_next_var,ai_next_var_of_fun,ai_var_heap}
consumerRequirements (Let {let_strict_binds, let_lazy_binds,let_expr}) common_defs ai=:{ai_next_var,ai_next_var_of_fun,ai_var_heap}
# let_binds = let_strict_binds ++ let_lazy_binds
# (new_next_var, new_ai_next_var_of_fun, ai_var_heap) = init_variables let_binds ai_next_var ai_next_var_of_fun ai_var_heap
# ai = acc_requirements_of_let_binds let_binds ai_next_var common_defs
{ ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap }
......@@ -646,13 +647,15 @@ where
-> transformApplication app exprs ro ti
_
-> (expr @ exprs, ti)
transform (Let lad=:{let_binds, let_expr}) ro ti
transform (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) ro ti
# ti = store_type_info_of_bindings_in_heap lad ti
(let_binds, ti) = transform let_binds ro ti
(let_strict_binds, ti) = transform let_strict_binds ro ti
(let_lazy_binds, ti) = transform let_lazy_binds ro ti
(let_expr, ti) = transform let_expr ro ti
= (Let { lad & let_binds = let_binds, let_expr = let_expr}, ti)
= (Let { lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}, ti)
where
store_type_info_of_bindings_in_heap {let_binds,let_info_ptr} ti
store_type_info_of_bindings_in_heap {let_strict_binds, let_lazy_binds,let_info_ptr} ti
# let_binds = let_strict_binds ++ let_lazy_binds
# (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap
ti_var_heap = foldSt (\(var_type, {bind_dst={fv_info_ptr}}) var_heap
->setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap)
......@@ -800,9 +803,10 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf
Let lad
| not is_active
-> skip_over this_case ro ti
# (new_let_binds, ti) = transform lad.let_binds { ro & ro_root_case_mode = NotRootCase } ti
# (let_strict_binds, ti) = transform lad.let_strict_binds { ro & ro_root_case_mode = NotRootCase } ti
(let_lazy_binds, ti) = transform lad.let_lazy_binds { ro & ro_root_case_mode = NotRootCase } ti
(new_let_expr, ti) = transform (Case { this_case & case_expr = lad.let_expr }) ro ti
-> (Let { lad & let_expr = new_let_expr, let_binds = new_let_binds }, ti)
-> (Let { lad & let_expr = new_let_expr, let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds }, ti)
_ -> skip_over this_case ro ti
where
equal (SK_Function glob_index1) (SK_Function glob_index2)
......@@ -917,10 +921,10 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf
# {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[glob_index]
let_type = filterWith not_unfoldable cons_type.st_args
(new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap
= ( Let { let_strict = False
, let_binds = [ {bind_src=bind_src, bind_dst=bind_dst} \\ (bind_dst,bind_src)<-non_unfoldable_args]
, let_expr = ap_expr
, let_info_ptr = new_info_ptr
= ( Let { let_strict_binds = []
, let_lazy_binds = [ {bind_src=bind_src, bind_dst=bind_dst} \\ (bind_dst,bind_src)<-non_unfoldable_args]
, let_expr = ap_expr
, let_info_ptr = new_info_ptr
}
, ti_symbol_heap
)
......@@ -2088,8 +2092,9 @@ where
= freeVariables app_args fvi
freeVariables (fun @ args) fvi
= freeVariables args (freeVariables fun fvi)
freeVariables (Let {let_binds,let_expr,let_info_ptr}) fvi=:{fvi_variables = global_variables}
# (removed_variables, fvi_var_heap) = removeVariables global_variables fvi.fvi_var_heap
freeVariables (Let {let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) fvi=:{fvi_variables = global_variables}
# let_binds = let_strict_binds ++ let_lazy_binds
(removed_variables, fvi_var_heap) = removeVariables global_variables fvi.fvi_var_heap
fvi = freeVariables let_binds { fvi & fvi_variables = [], fvi_var_heap = fvi_var_heap }
{fvi_expr_heap, fvi_variables, fvi_var_heap, fvi_expr_ptrs} = freeVariables let_expr fvi
(fvi_variables, fvi_var_heap) = removeLocalVariables [bind_dst \\ {bind_dst} <- let_binds] fvi_variables [] fvi_var_heap
......
frontend/transform.icl
View file @ a42774b8
......@@ -43,9 +43,11 @@ where
lift (expr @ exprs) ls
# ((expr,exprs), ls) = lift (expr,exprs) ls
= (expr @ exprs, ls)
lift (Let lad=:{let_binds, let_expr}) ls
# ((let_binds,let_expr), ls) = lift (let_binds,let_expr) ls
= (Let {lad & let_binds = let_binds, let_expr = let_expr}, ls)
lift (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) ls
# (let_strict_binds, ls) = lift let_strict_binds ls
(let_lazy_binds, ls) = lift let_lazy_binds ls
(let_expr, ls) = lift let_expr ls
= (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr}, ls)
lift (Case case_expr) ls
# (case_expr, ls) = lift case_expr ls
= (Case case_expr, ls)
......@@ -406,13 +408,16 @@ where
instance unfold Let
where
unfold lad=:{let_binds, let_expr, let_info_ptr} us
# (let_binds, us) = copy_bound_vars let_binds us
# ((let_binds,let_expr), us) = unfold (let_binds,let_expr) us
unfold lad=:{let_strict_binds, let_lazy_binds, let_expr, let_info_ptr} us
# (let_strict_binds, us) = copy_bound_vars let_strict_binds us
# (let_lazy_binds, us) = copy_bound_vars let_lazy_binds us
# (let_strict_binds, us) = unfold let_strict_binds us
# (let_lazy_binds, us) = unfold let_lazy_binds us
# (let_expr, us) = unfold let_expr us
(old_let_info, us_symbol_heap) = readPtr let_info_ptr us.us_symbol_heap
(new_let_info, us_opt_type_heaps) = substitute_let_or_case_type old_let_info us.us_opt_type_heaps
(new_info_ptr, us_symbol_heap) = newPtr new_let_info us_symbol_heap
= ({lad & let_binds = let_binds, let_expr = let_expr, let_info_ptr = new_info_ptr},
= ({lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr, let_info_ptr = new_info_ptr},
{ us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps })
where
copy_bound_vars [bind=:{bind_dst} : binds] us
......@@ -498,7 +503,7 @@ unfoldMacro {fun_body = TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls}}
| isEmpty let_binds
= (result_expr, fun_defs, (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table }))
# (new_info_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap
= (Let { let_strict = cIsNotStrict, let_binds = let_binds, let_expr = result_expr, let_info_ptr = new_info_ptr}, fun_defs,
= (Let { let_strict_binds = [], let_lazy_binds = let_binds, let_expr = result_expr, let_info_ptr = new_info_ptr}, fun_defs,
(calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table }))
where
......@@ -1033,9 +1038,11 @@ where
expand (expr @ exprs) fun_and_macro_defs mod_index modules es
# ((expr,exprs), fun_and_macro_defs, modules, es) = expand (expr,exprs) fun_and_macro_defs mod_index modules es
= (expr @ exprs, fun_and_macro_defs, modules, es)
expand (Let lad=:{let_binds, let_expr}) fun_and_macro_defs mod_index modules es
# ((let_binds,let_expr), fun_and_macro_defs, modules, es) = expand (let_binds,let_expr) fun_and_macro_defs mod_index modules es
= (Let {lad & let_expr = let_expr, let_binds = let_binds}, fun_and_macro_defs, modules, es)
expand (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) fun_and_macro_defs mod_index modules es
# (let_strict_binds, fun_and_macro_defs, modules, es) = expand let_strict_binds fun_and_macro_defs mod_index modules es
# (let_lazy_binds, fun_and_macro_defs, modules, es) = expand let_lazy_binds fun_and_macro_defs mod_index modules es
# (let_expr, fun_and_macro_defs, modules, es) = expand let_expr fun_and_macro_defs mod_index modules es
= (Let {lad & let_expr = let_expr, let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds}, fun_and_macro_defs, modules, es)
expand (Case case_expr) fun_and_macro_defs mod_index modules es
# (case_expr, fun_and_macro_defs, modules, es) = expand case_expr fun_and_macro_defs mod_index modules es
= (Case case_expr, fun_and_macro_defs, modules, es)
......@@ -1177,17 +1184,21 @@ where
collectVariables (expr @ exprs) free_vars cos
# ((expr, exprs), free_vars, cos) = collectVariables (expr, exprs) free_vars cos
= (expr @ exprs, free_vars, cos)
collectVariables (Let lad=:{let_binds, let_expr}) free_vars cos=:{cos_var_heap}
# cos_var_heap = determine_aliases let_binds cos_var_heap
(is_cyclic, let_binds, cos_var_heap) = detect_cycles_and_remove_alias_binds let_binds cos_var_heap
| is_cyclic
= (Let {lad & let_binds = let_binds }, free_vars, { cos & cos_var_heap = cos_var_heap, cos_error = checkError "" "cyclic let definition" cos.cos_error})
collectVariables (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) free_vars cos=:{cos_var_heap}
# cos_var_heap = determine_aliases let_strict_binds cos_var_heap
# cos_var_heap = determine_aliases let_lazy_binds cos_var_heap
(is_cyclic_s, let_strict_binds, cos_var_heap) = detect_cycles_and_remove_alias_binds let_strict_binds cos_var_heap
(is_cyclic_l, let_lazy_binds, cos_var_heap) = detect_cycles_and_remove_alias_binds let_lazy_binds cos_var_heap
| is_cyclic_s || is_cyclic_l
= (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_binds, free_vars, cos) = collect_variables_in_binds let_binds [] free_vars cos
| isEmpty let_binds
# (let_expr, free_vars, cos) = collectVariables let_expr free_vars { cos & cos_var_heap = cos_var_heap }