Commit b2e6d4e3 authored by John van Groningen's avatar John van Groningen
Browse files

in derived dynamic types, add uniqueness to algebraic types that are always unique

(the type definition has a * on the left),
add Bool to GTT_Constructor to indicate uniqueness,
generate TCE_UnqType in TypeCode for unique GTT_Constructor's,
this uniqueness property should be propagated, but this is not implemented yet
parent 091f4fb2
...@@ -560,7 +560,7 @@ where ...@@ -560,7 +560,7 @@ where
-> type_code_constructor_expression PD_TC__StrictArray ci -> type_code_constructor_expression PD_TC__StrictArray ci
PD_UnboxedArrayType PD_UnboxedArrayType
-> type_code_constructor_expression PD_TC__UnboxedArray ci -> type_code_constructor_expression PD_TC__UnboxedArray ci
typeConstructor (GTT_Constructor fun_ident) ci typeConstructor (GTT_Constructor fun_ident _) ci
# type_fun # type_fun
= App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr} = App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr}
= (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [type_fun], app_info_ptr = nilPtr}, ci) = (App {app_symb = cinp_dynamic_representation.dr_type_code_constructor_symb_ident, app_args = [type_fun], app_info_ptr = nilPtr}, ci)
......
...@@ -1004,7 +1004,12 @@ where ...@@ -1004,7 +1004,12 @@ where
({ heaps & hp_type_heaps = hp_type_heaps }, ptrs)) ({ heaps & hp_type_heaps = hp_type_heaps }, ptrs))
adjust_member_application defs contexts _ (CA_GlobalTypeCode {tci_constructor,tci_contexts}) _ heaps_and_ptrs adjust_member_application defs contexts _ (CA_GlobalTypeCode {tci_constructor,tci_contexts}) _ heaps_and_ptrs
# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs # (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
= (EI_TypeCode (TCE_Constructor tci_constructor (expressionsToTypeCodeExpressions exprs)), heaps_and_ptrs) typeCodeExpressions = expressionsToTypeCodeExpressions exprs
= case tci_constructor of
GTT_Constructor _ True
-> (EI_TypeCode (TCE_UnqType (TCE_Constructor tci_constructor typeCodeExpressions)), heaps_and_ptrs)
_
-> (EI_TypeCode (TCE_Constructor tci_constructor typeCodeExpressions), heaps_and_ptrs)
adjust_member_application defs contexts _ (CA_LocalTypeCode new_var_ptr) _ heaps_and_ptrs adjust_member_application defs contexts _ (CA_LocalTypeCode new_var_ptr) _ heaps_and_ptrs
= (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs) = (EI_TypeCode (TCE_Var new_var_ptr), heaps_and_ptrs)
...@@ -1117,7 +1122,12 @@ where ...@@ -1117,7 +1122,12 @@ where
= (TypeCodeExpression (TCE_Var new_var_ptr), heaps_and_ptrs) = (TypeCodeExpression (TCE_Var new_var_ptr), heaps_and_ptrs)
convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_constructor,tci_contexts}) heaps_and_ptrs convert_class_appl_to_expression defs contexts (CA_GlobalTypeCode {tci_constructor,tci_contexts}) heaps_and_ptrs
# (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs # (exprs, heaps_and_ptrs) = convertClassApplsToExpressions defs contexts tci_contexts heaps_and_ptrs
= (TypeCodeExpression (TCE_Constructor tci_constructor (expressionsToTypeCodeExpressions exprs)), heaps_and_ptrs) typeCodeExpressions = expressionsToTypeCodeExpressions exprs
= case tci_constructor of
GTT_Constructor _ True
-> (TypeCodeExpression (TCE_UnqType (TCE_Constructor tci_constructor typeCodeExpressions)), heaps_and_ptrs)
_
-> (TypeCodeExpression (TCE_Constructor tci_constructor typeCodeExpressions), heaps_and_ptrs)
convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps_and_ptrs convert_reduced_contexts_to_expression defs contexts {rcs_class_context,rcs_constraints_contexts} heaps_and_ptrs
# (rcs_exprs, heaps_and_ptrs) = mapSt (convert_class_appl_to_expression defs contexts) rcs_constraints_contexts heaps_and_ptrs # (rcs_exprs, heaps_and_ptrs) = mapSt (convert_class_appl_to_expression defs contexts) rcs_constraints_contexts heaps_and_ptrs
...@@ -1493,7 +1503,11 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c ...@@ -1493,7 +1503,11 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c
= { symb_ident = {id_name = "TD;"+++type.td_ident.id_name, id_info = nilPtr} = { symb_ident = {id_name = "TD;"+++type.td_ident.id_name, id_info = nilPtr}
, symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index} , symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index}
} }
= GTT_Constructor type_fun # is_unique_type
= case type.td_attribute of
TA_Unique -> True
_ -> False
= GTT_Constructor type_fun is_unique_type
fatal :: {#Char} {#Char} -> .a fatal :: {#Char} {#Char} -> .a
fatal function_name message fatal function_name message
...@@ -1511,7 +1525,7 @@ instance toTypeCodeExpression Type where ...@@ -1511,7 +1525,7 @@ instance toTypeCodeExpression Type where
= toTypeCodeExpression type (tci,var_heap,error) = toTypeCodeExpression type (tci,var_heap,error)
# type_constructor = toTypeCodeConstructor type_index tci_common_defs # type_constructor = toTypeCodeConstructor type_index tci_common_defs
(type_code_args, tci) (type_code_args, tci)
= mapSt (toTypeCodeExpression) type_args (tci,var_heap,error) = mapSt toTypeCodeExpression type_args (tci,var_heap,error)
= (TCE_Constructor type_constructor type_code_args, tci) = (TCE_Constructor type_constructor type_code_args, tci)
toTypeCodeExpression (TAS cons_id type_args _) state toTypeCodeExpression (TAS cons_id type_args _) state
= toTypeCodeExpression (TA cons_id type_args) state = toTypeCodeExpression (TA cons_id type_args) state
......
...@@ -1476,7 +1476,7 @@ instance == OverloadedListType ...@@ -1476,7 +1476,7 @@ instance == OverloadedListType
:: GlobalTCType :: GlobalTCType
= GTT_Basic !BasicType = GTT_Basic !BasicType
| GTT_Constructor !SymbIdent | GTT_Constructor !SymbIdent !Bool/*is unique type*/
| GTT_PredefTypeConstructor !(Global Index) | GTT_PredefTypeConstructor !(Global Index)
| GTT_Function | GTT_Function
......
...@@ -448,6 +448,8 @@ where ...@@ -448,6 +448,8 @@ where
= file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< info_ptr = file <<< "TCE_Selector " <<< selectors <<< "VAR " <<< info_ptr
(<<<) file (TCE_UniType vars type_code) (<<<) file (TCE_UniType vars type_code)
= file <<< "TCE_UniType " <<< vars <<< " " <<< type_code = file <<< "TCE_UniType " <<< vars <<< " " <<< type_code
(<<<) file (TCE_UnqType type_code)
= file <<< "TCE_UnqType " <<< type_code
instance <<< (Ptr a) instance <<< (Ptr a)
where where
......
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