small changes to reduce memory allocation

frontend/check.icl

@@ -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)

frontend/explicitimports.icl

@@ -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)

frontend/frontend.icl

@@ -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,

frontend/transform.icl

@@ -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)

frontend/type.icl

@@ -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)

frontend/unitype.icl

@@ -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 }