Commit 2980941b authored by clean's avatar clean
Browse files

small changes to reduce memory allocation

parent 40e467c3
......@@ -279,6 +279,7 @@ where
check_member_instances :: !Index !Index !Int !Int !{#DefinedSymbol} !{#DefinedSymbol} !InstanceType ![(Index,SymbolType)]
!v:{# MemberDef} !u:{# DclModule} !*VarHeap !*TypeHeaps !*CheckState
-> (![(Index,SymbolType)], !v:{# MemberDef}, !u:{# DclModule},!*VarHeap, !*TypeHeaps, !*CheckState)
check_member_instances module_index member_mod_index mem_offset class_size ins_members class_members
ins_type instance_types member_defs modules var_heap type_heaps cs
| mem_offset == class_size
......@@ -562,7 +563,6 @@ where
-> (Yes (type_def,glob_module), selector_defs, type_defs, modules, cs)
No
-> (No, selector_defs, type_defs, modules, { cs & cs_error = checkError "" " could not determine the type of this record" cs.cs_error })
check_and_rearrange_fields mod_index field_index fields field_ass cs_error
| field_index < size fields
......@@ -734,7 +734,6 @@ where
determine_pattern_symbol mod_index id_index id_kind id_name cons_defs modules error
= (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError id_name " constructor expected" error)
checkIdentPattern :: !Bool !Ident !(Optional (Bind Ident VarInfoPtr)) !PatternInput !(![Ident], ![ArrayPattern]) !*PatternState !*ExpressionInfo !*CheckState
-> (!AuxiliaryPattern, !(![Ident], ![ArrayPattern]), !*PatternState, !*ExpressionInfo, !*CheckState)
checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_mod_index} accus=:(var_env, array_patterns)
......@@ -963,6 +962,12 @@ where
bind_opt_record_variable no is_node_pattern patterns _ var_heap
= (patterns, var_heap)
checkPattern (PE_Bound bind) opt_var p_input accus ps e_info cs
= checkBoundPattern bind opt_var p_input accus ps e_info cs
checkPattern (PE_Ident id) opt_var p_input accus ps e_info cs
= checkIdentPattern cIsNotInExpressionList id opt_var p_input accus ps e_info cs
checkPattern PE_WildCard opt_var p_input accus ps e_info cs
= (AP_WildCard No, accus, ps, e_info, cs)
checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patterns) ps e_info cs
# (var_env, ap_selections, ps_var_heap, cs)
= foldSt (check_array_selection p_input.pi_def_level) selections (var_env, [], ps.ps_var_heap, cs)
......@@ -998,14 +1003,6 @@ checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patter
check_rhs _ _ (var_env, ap_selections, var_heap, cs)
= (var_env, ap_selections, var_heap,
{ cs & cs_error = checkError "" "variable expected on right hand side of array pattern" cs.cs_error })
checkPattern (PE_Bound bind) opt_var p_input accus ps e_info cs
= checkBoundPattern bind opt_var p_input accus ps e_info cs
checkPattern (PE_Ident id) opt_var p_input accus ps e_info cs
= checkIdentPattern cIsNotInExpressionList id opt_var p_input accus ps e_info cs
checkPattern PE_WildCard opt_var p_input accus ps e_info cs
= (AP_WildCard No, accus, ps, e_info, cs)
checkPattern expr opt_var p_input accus ps e_info cs
= abort "checkPattern: do not know how to handle pattern" ---> expr
......@@ -1829,6 +1826,8 @@ transfromPatternIntoBind _ _ pattern src_expr var_store expr_heap e_info cs
checkLocalFunctions mod_index level (CollectedLocalDefs {loc_functions={ir_from,ir_to}}) fun_defs e_info heaps cs
= checkFunctions mod_index level ir_from ir_to fun_defs e_info heaps cs
// JVG: added type
checkRhs :: [FreeVar] OptGuardedAlts LocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
checkRhs free_vars rhs_alts rhs_locals e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# ei_expr_level = inc ei_expr_level
(loc_defs, (var_env, array_patterns), e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index rhs_locals e_state e_info cs
......@@ -1890,6 +1889,8 @@ where
(expr, free_vars, e_state, e_info, cs) = check_opt_guarded_alts free_vars alt_expr e_input e_state e_info cs
= (let_vars_list, [(let_binds, guard, expr) : rev_guarded_exprs], ei_expr_level, free_vars, e_state, e_info, cs )
// JVG: added type
check_unguarded_expression :: [FreeVar] ExprWithLocalDefs ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
check_unguarded_expression free_vars {ewl_nodes,ewl_expr,ewl_locals} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# this_expr_level = inc ei_expr_level
(loc_defs, (var_env, array_patterns), e_state, e_info, cs)
......@@ -1931,6 +1932,8 @@ where
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)
// JVG: added type
check_sequential_let :: [FreeVar] NodeDefWithLocals ExpressionInput *ExpressionState *ExpressionInfo *CheckState -> *(!Expression,!AuxiliaryPattern,!(![Ident],![ArrayPattern]),![FreeVar],!*ExpressionState,!*ExpressionInfo,!*CheckState);
check_sequential_let free_vars {ndwl_def={bind_src,bind_dst},ndwl_locals} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# (loc_defs, (loc_env, loc_array_patterns), e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index ndwl_locals e_state e_info cs
(src_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars bind_src e_input e_state e_info cs
......@@ -2014,6 +2017,7 @@ convertSubPattern (AP_WildCard opt_var) result_expr var_store expr_heap opt_dyna
convertSubPattern (AP_Empty _) result_expr var_store expr_heap opt_dynamics cs
= convertSubPattern (AP_WildCard No) EE var_store expr_heap opt_dynamics cs
typeOfBasicValue :: !BasicValue !*CheckState -> (!BasicType, !*CheckState)
typeOfBasicValue (BVI _) cs = (BT_Int, cs)
typeOfBasicValue (BVC _) cs = (BT_Char, cs)
......
......@@ -448,7 +448,8 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n
= abort "element_appears_in_stomm_struct will be never called, when the above guard holds. This statement is only to remind people to remove this function."
# (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index]
(module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
cs = { cs & cs_symbol_table=cs_symbol_table }
//JVG: add #!
#! cs = { cs & cs_symbol_table=cs_symbol_table }
= continuation imported_st module_entry.ste_kind dcl_module modules cs
where
continuation ST_RecordType (STE_OpenModule _ modul) _ modules cs
......@@ -558,9 +559,17 @@ check_completeness_of_module mod_index dcls_explicit file_name (f_consequences,
# dcls_imp = [((dcl_ident, kind), (dcl_index, mod_index), (file_name, line_nr))
\\ ({dcl_ident, dcl_index, dcl_kind=STE_Imported kind mod_index}, line_nr) <- dcls_explicit]
(conseqs, (f_consequences, modules, icl_functions, expr_heap))
/* JVG:
= seqList (map (consequences_of mod_index) dcls_imp) (f_consequences, modules, icl_functions, expr_heap)
*/
= mapSt (consequences_of mod_index) dcls_imp (f_consequences, modules, icl_functions, expr_heap)
/**/
conseqs = flatten conseqs
/*JVG:
#! (modules, cs) = seq (map checkConsequenceError conseqs) (modules, cs)
*/
#! (modules, cs) = foldr checkConsequenceError (modules, cs) conseqs
/**/
= (f_consequences, modules, icl_functions, expr_heap, cs)
consequences_of :: !Index
......@@ -568,6 +577,7 @@ consequences_of :: !Index
-> (![(!IdentWithKind, !IdentWithCKind, !(!String, !Int))], !(*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap))
consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_index), errMsgInfo)
(f_consequences, modules, icl_functions, expr_heap)
/* JVG:
# (modul, modules) = modules![mod_index]
(consequences, (f_consequences, icl_functions, expr_heap))
= case expl_imp_kind of
......@@ -577,6 +587,18 @@ consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_i
-> (consequences_of_simple_symbol expl_imp_kind modul dcl_index, (f_consequences, icl_functions,expr_heap))
conseqs = removeDup consequences
= ([(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-conseqs], (f_consequences, modules, icl_functions, expr_heap))
*/
= case expl_imp_kind of
STE_FunctionOrMacro _
# (consequences, (f_consequences, icl_functions, expr_heap)) = consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
-> (add_kind_and_error_info_to_consequences consequences, (f_consequences, modules, icl_functions, expr_heap))
_
# (modul, modules) = modules![mod_index]
-> (add_kind_and_error_info_to_consequences (consequences_of_simple_symbol expl_imp_kind modul dcl_index), (f_consequences, modules, icl_functions, expr_heap))
where
add_kind_and_error_info_to_consequences consequences
= [(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-removeDup consequences]
/**/
consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
# (icl_function, icl_functions) = icl_functions![dcl_index]
......@@ -666,6 +688,9 @@ consequences_of_simple_symbol STE_Member {dcl_common} dcl_index
consequences_of_simple_symbol STE_Instance {dcl_common} dcl_index
= consequences dcl_common.com_instance_defs.[dcl_index]
// JVG added type:
checkConsequenceError :: !((Ident,.STE_Kind),!.(Ident,ConsequenceKind),!(.{#Char},.Int)) !*(*{#DclModule},!*CheckState) -> (!*{#DclModule},!.CheckState)
checkConsequenceError (expl_imp_ident_kind, conseq_ident_kind=:(conseq_ident, conseq_kind), (file_name, line_nr))
(modules, cs=:{cs_symbol_table, cs_error})
# (c_ident, modules)
......
......@@ -36,6 +36,9 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i
= (predef_symbols, hash_table, files, error, io, out, No)
# {icl_functions,icl_instances,icl_specials,icl_common,icl_declared} = icl_mod
// (components, icl_functions, error) = showComponents components 0 True icl_functions error
dcl_mods = {{dcl_mod & dcl_declared={dcls_import=[],dcls_local=[],dcls_explicit=[]}}\\ dcl_mod<-:dcl_mods}
(ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, error)
= typeProgram (components -*-> "Typing") icl_functions icl_specials icl_common icl_declared.dcls_import dcl_mods heaps predef_symbols error
| not ok
......@@ -57,11 +60,15 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i
= transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics var_heap type_heaps expression_heap
(dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps
(dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps
// (components, fun_defs, out) = showComponents components 0 False fun_defs out
(used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses
var_heap type_heaps expression_heap
(dcl_types, type_heaps, var_heap)
= convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap
// (components, fun_defs, error) = showTypes components 0 fun_defs error
// (components, fun_defs, out) = showComponents components 0 False fun_defs out
= (predef_symbols,hash_table,files,error,io,out,
......
......@@ -1154,6 +1154,8 @@ determineVariablesAndRefCounts free_vars expr cos=:{cos_var_heap}
retrieveRefCounts free_vars var_heap
= mapSt retrieveRefCount free_vars var_heap
// JVG: added type:
retrieveRefCount :: FreeVar *(Heap VarInfo) -> (!FreeVar,!.Heap VarInfo);
retrieveRefCount fv=:{fv_info_ptr} var_heap
# (VI_Count count _, var_heap) = readPtr fv_info_ptr var_heap
= ({ fv & fv_count = count }, var_heap)
......
......@@ -518,8 +518,9 @@ freshSymbolType fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_
| new_var_id == var_id
= vars
= [var_id : add_variable new_var_id var_ids]
// JVG: added type:
freshInequality :: AttrInequality *(Heap AttrVarInfo) -> (!AttrCoercion,!.Heap AttrVarInfo);
freshInequality {ai_demanded,ai_offered} attr_heap
# (av_dem_info, attr_heap) = readPtr ai_demanded.av_info_ptr attr_heap
(av_off_info, attr_heap) = readPtr ai_offered.av_info_ptr attr_heap
......@@ -810,12 +811,20 @@ where
requirements ti {var_name,var_info_ptr,var_expr_ptr} (reqs, ts)
# (var_info, ts_var_heap) = readPtr var_info_ptr ts.ts_var_heap
ts = { ts & ts_var_heap = ts_var_heap }
/* JVG: changed to reduce allocation because the case is polymorphic and lazy in req and ts: */
= (case var_info of
VI_Type type
-> type
_
-> abort ("requirements BoundVar" ---> (var_name <<- var_info))
, Yes var_expr_ptr, (reqs, ts))
/*
= case var_info of
VI_Type type
-> (type, Yes var_expr_ptr, (reqs, ts))
_
-> abort ("requirements BoundVar" ---> (var_name <<- var_info))
*/
instance requirements App
where
requirements ti {app_symb,app_args,app_info_ptr} (reqs=:{req_cons_variables, req_attr_coercions}, ts)
......@@ -1422,6 +1431,7 @@ typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_ex
type_code_instances = {createArray si_next_TC_member_index GTT_Function & [gtci_index] = gtci_type \\ {gtci_index, gtci_type} <- si_TC_instances}
= (not type_error, fun_defs, { ir_from = fun_env_size, ir_to = si_next_array_member_index }, type_code_instances, ti_common_defs, ti_functions,
{hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file)
// ---> ("typeProgram", array_inst_types)
where
collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos
= foldSt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos)
......
......@@ -228,7 +228,6 @@ liftTempTypeVariable modules cons_vars tv_number subst ls
class lift a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState
-> (!a, !*{! Type}, !*LiftState)
instance lift Type
where
lift modules cons_vars (TempV tv_number) subst ls
......@@ -542,6 +541,8 @@ makeUnique attr {coer_demanded, coer_offered}
coer_demanded = { coer_demanded & [attr] = CT_Unique }
= make_unique off_coercions {coer_offered = coer_offered, coer_demanded = coer_demanded}// ---> ("makeUnique :", attr)
where
// JVG added type:
make_unique :: !CoercionTree !*Coercions -> *Coercions;
make_unique (CT_Node this_attr ct_less ct_greater) coercions
# coercions = makeUnique this_attr coercions
coercions = make_unique ct_less coercions
......@@ -563,6 +564,8 @@ makeNonUnique attr {coer_demanded, coer_offered}
= make_non_unique dem_coercions {coer_offered = coer_offered, coer_demanded = coer_demanded}
// ---> ("makeNonUnique", attr)
where
// JVG added type:
make_non_unique :: !CoercionTree !*Coercions -> *Coercions;
make_non_unique (CT_Node this_attr ct_less ct_greater) coercions
# coercions = makeNonUnique this_attr coercions
coercions = make_non_unique ct_less coercions
......@@ -588,7 +591,9 @@ Success (Yes _) = False
instance coerce AType
where
coerce sign defs cons_vars tpos at1=:{at_attribute=attr1, at_type = type1} at2=:{at_attribute=attr2} cs=:{crc_coercions}
# attr_sign = adjust_sign sign type1 cons_vars
// JVG: added !
#!attr_sign = adjust_sign sign type1 cons_vars
// # attr_sign = adjust_sign sign type1 cons_vars
(succ, crc_coercions) = coerceAttributes attr1 attr2 attr_sign crc_coercions
| succ
# (succ, cs) = coerceTypes sign defs cons_vars tpos at1 at2 { cs & crc_coercions = crc_coercions }
......
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