Commit 4a1404f8 authored by John van Groningen's avatar John van Groningen
Browse files

store strictness annotations in SymbolType instead of AType

parent 895ef836
......@@ -790,12 +790,14 @@ declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_symb, ft_type_ptr}
functionName :: {#Char} Int Int -> {#Char}
functionName name functionIndex nrOfDclFunctions
// | trace_tn (name+++(if (functionIndex < nrOfDclFunctions) "" (";" +++ toString functionIndex)))
| functionIndex < nrOfDclFunctions
= name
// otherwise
= name +++ ";" +++ toString functionIndex
import StdDebug
//import StdDebug
/*
declareCurrentDclModuleTypes :: {#CheckedTypeDef} {#Int} -> BackEnder
......@@ -824,10 +826,13 @@ defineType moduleIndex constructors _ typeIndex {td_name, td_args, td_rhs=AlgTyp
= convertConstructors typeIndex td_name.id_name moduleIndex constructors constructorSymbols be
= appBackEnd (BEAlgebraicType flatType constructors) be
defineType moduleIndex constructors selectors typeIndex {td_args, td_rhs=RecordType {rt_constructor, rt_fields}} be
// | trace_tn constructorDef.cons_symb
# (flatType, be)
= convertTypeLhs moduleIndex typeIndex td_args be
# (fields, be)
= convertSelectors moduleIndex selectors rt_fields be
// = convertSelectors moduleIndex selectors rt_fields be
= convertSelectors moduleIndex selectors rt_fields constructorDef.cons_type.st_args_strictness be
# (constructorType,be) = constructorTypeFunction be
# (constructorTypeNode, be)
= beNormalTypeNode
......@@ -875,15 +880,32 @@ convertConstructor typeIndex typeName moduleIndex constructorDefs {ds_index}
_
-> (constructorDef.cons_type,be)) // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, constructorDef.cons_type)
convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
convertSelectors moduleIndex selectors symbols
= foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
convertSelector moduleIndex selectorDefs {fs_index}
foldrAi function result array
:== foldrA 0
where
arraySize
= size array
foldrA index
| index == arraySize
= result
// otherwise
= function index array.[index] (foldrA (index+1))
//convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} -> BEMonad BEFieldListP
convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} StrictnessList -> BEMonad BEFieldListP
convertSelectors moduleIndex selectors symbols strictness
// = foldrA (beFields o convertSelector moduleIndex selectors) beNoFields symbols
= foldrAi (\i -> (beFields o convertSelector moduleIndex selectors (arg_is_strict i strictness))) beNoFields symbols
//convertSelector :: ModuleIndex {#SelectorDef} FieldSymbol -> BEMonad BEFieldListP
convertSelector :: ModuleIndex {#SelectorDef} Bool FieldSymbol -> BEMonad BEFieldListP
//convertSelector moduleIndex selectorDefs {fs_index}
convertSelector moduleIndex selectorDefs is_strict {fs_index}
= \be0 -> let (selectorType,be) = selectorTypeFunction be0 in
( appBackEnd (BEDeclareField fs_index moduleIndex selectorDef.sd_symb.id_name)
o` beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))) be
// o` beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))) be
o` beField fs_index moduleIndex (convertAnnotAndTypeNode (if is_strict AN_Strict AN_None) (selectorType.st_result))) be
where
selectorDef
= selectorDefs.[fs_index]
......@@ -1238,6 +1260,7 @@ convertRules rules main_dcl_module_n aliasDummyId be
convertRule :: Ident (Int,FunDef) Int -> BEMonad BEImpRuleP
convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb}) main_dcl_module_n
// | trace_tn fun_symb.id_name
= beRule index (cafness fun_kind)
(convertTypeAlt index main_dcl_module_n (type -*-> ("convertRule", fun_symb.id_name, index, type)))
(convertFunctionBody index (positionToLineNumber fun_pos) aliasDummyId body main_dcl_module_n)
......@@ -1324,8 +1347,9 @@ convertAttributeKind attributeVar
= beAttributeKind (convertAttributeVar attributeVar)
convertSymbolTypeArgs :: SymbolType -> BEMonad BETypeArgP
convertSymbolTypeArgs {st_args}
= convertTypeArgs st_args
convertSymbolTypeArgs {st_args,st_args_strictness}
// = convertTypeArgs st_args
= convertAnnotatedTypeArgs st_args st_args_strictness
convertBasicTypeKind :: BasicType -> BESymbKind
convertBasicTypeKind BT_Int
......@@ -1392,7 +1416,7 @@ convertAttribution attr
= abort "backendconvert, convertAttribution: unknown TypeAttribute" // <<- attr
convertAnnotTypeNode :: AType -> BEMonad BETypeNodeP
convertAnnotTypeNode {at_type, at_annotation, at_attribute}
convertAnnotTypeNode {at_type, at_attribute}
/*
= convertTypeNode at_type
:- beAnnotateTypeNode (convertAnnotation at_annotation)
......@@ -1404,6 +1428,15 @@ convertAnnotTypeNode {at_type, at_annotation, at_attribute}
:- beAnnotateTypeNode c_annot
:- beAttributeTypeNode c_attrib
// ) s
where
c_annot = convertAnnotation AN_None // at_annotation
c_attrib = convertAttribution at_attribute
convertAnnotAndTypeNode :: Annotation AType -> BEMonad BETypeNodeP
convertAnnotAndTypeNode at_annotation {at_type, at_attribute}
= convertTypeNode at_type
:- beAnnotateTypeNode c_annot
:- beAttributeTypeNode c_attrib
where
c_annot = convertAnnotation at_annotation
c_attrib = convertAttribution at_attribute
......@@ -1417,6 +1450,9 @@ convertTypeNode (TB basicType)
= beNormalTypeNode (beBasicSymbol (convertBasicTypeKind basicType)) beNoTypeArgs
convertTypeNode (TA typeSymbolIdent typeArgs)
= beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs )
convertTypeNode (TAS typeSymbolIdent typeArgs strictness)
// = beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs )
= beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertAnnotatedTypeArgs typeArgs strictness)
convertTypeNode (TV {tv_name})
= beVarTypeNode tv_name.id_name
convertTypeNode (TempQV n)
......@@ -1426,7 +1462,7 @@ convertTypeNode (TempV n)
convertTypeNode (a --> b)
= beNormalTypeNode (beBasicSymbol BEFunType) (convertTypeArgs [a, b])
convertTypeNode (a :@: b)
= beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_annotation=AN_None, at_type = consVariableToType a} : b])
= beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_type = consVariableToType a} : b])
convertTypeNode TE
= beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
convertTypeNode (TFA vars type)
......@@ -1446,6 +1482,16 @@ convertTypeArgs :: [AType] -> BEMonad BETypeArgP
convertTypeArgs args
= sfoldr (beTypeArgs o convertAnnotTypeNode) beNoTypeArgs args
convertAnnotatedTypeArgs :: [AType] StrictnessList -> BEMonad BETypeArgP
convertAnnotatedTypeArgs args strictness
= foldr args 0
where
foldr [] i
= beNoTypeArgs
foldr [a:x] i
// | trace_tn (toString i+++" "+++toString (arg_strictness_annotation i strictness))
= (beTypeArgs o (convertAnnotAndTypeNode (arg_strictness_annotation i strictness))) a (foldr x (i+1))
convertTransformedBody :: Int Int Ident TransformedBody Int -> BEMonad BERuleAltP
convertTransformedBody functionIndex lineNumber aliasDummyId body main_dcl_module_n
| isCodeBlock body.tb_rhs
......
......@@ -99,6 +99,9 @@ printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap
printFunctionType all attr info (functionIndex, {fun_symb,fun_type=Yes type}) (attrHeap, file, backEnd)
| not all && functionIndex >= size info.dtic_dclModules.[info.dtci_iclModuleIndex].dcl_functions
= (attrHeap, file, backEnd)
// | trace_tn (toString fun_symb) && True ---> type.st_args
# (strictnessAdded, type, backEnd)
= addStrictnessFromBackEnd functionIndex fun_symb.id_name backEnd type
| not strictnessAdded && not all
......@@ -127,6 +130,9 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
= {si_robust_encoding = False, si_positions = strictPositions, si_size = bitSize, si_name = functionName}
offset
= 0
// | trace_tn (toString bitSize+++" "+++toString strictPositions.[0])
# (robust, offset)
= nextBit strictnessInfo offset
strictnessInfo
......@@ -134,11 +140,19 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
# (anyStrictnessAdded, offset)
= nextBit strictnessInfo offset
# (type, offset)
= addStrictness strictnessInfo type offset
= addStrictnessToSymbolType strictnessInfo type offset
# type
= checkFinalOffset strictnessInfo offset type
= (anyStrictnessAdded, type, backEnd)
addStrictnessToSymbolType strictPositions=:{si_size} args offset
| offset >= si_size // short cut
= (args, offset)
addStrictnessToSymbolType strictPositions type=:{st_args,st_args_strictness} offset
# (st_args, offset,args_strictness)
= addStrictness strictPositions st_args offset st_args_strictness 0
= ({type & st_args = st_args,st_args_strictness=args_strictness}, offset)
:: StrictnessInfo =
{ si_size :: !Int
, si_positions :: !LargeBitvect
......@@ -146,7 +160,7 @@ addStrictnessFromBackEnd functionIndex functionName backEnd type
, si_robust_encoding :: !Bool
}
class addStrictness a :: !StrictnessInfo !a Int -> (!a, !Int)
class addStrictness a :: !StrictnessInfo !a Int StrictnessList Int -> (!a, !Int,!StrictnessList)
nextBit :: StrictnessInfo Int -> (Bool, Int)
nextBit {si_size, si_positions, si_robust_encoding} offset
......@@ -187,58 +201,64 @@ checkFinalOffset info=:{si_size, si_robust_encoding} offset value
// otherwise
= value
instance addStrictness SymbolType where
addStrictness strictPositions=:{si_size} args offset
| offset >= si_size // short cut
= (args, offset)
addStrictness strictPositions type=:{st_args} offset
# (st_args, offset)
= addStrictness strictPositions st_args offset
= ({type & st_args = st_args}, offset)
instance addStrictness [a] | addStrictness a where
addStrictness strictPositions l offset
= mapSt (addStrictness strictPositions) l offset
addStrictness strictPositions [] offset args_strictness args_strictness_index
= ([],offset,args_strictness)
addStrictness strictPositions [type:types] offset args_strictness args_strictness_index
# (type,offset,args_strictness)=addStrictness strictPositions type offset args_strictness args_strictness_index
# (types,offset,args_strictness)=addStrictness strictPositions types offset args_strictness (args_strictness_index+1)
= ([type:types],offset,args_strictness)
instance addStrictness AType where
addStrictness strictPositions arg=:{at_annotation, at_type} offset
# (at_annotation, offset)
= addStrictness strictPositions at_annotation offset
addStrictness strictPositions arg=:{at_type} offset args_strictness args_strictness_index
# (is_strict,offset,args_strictness)
= addStrictnessAnnotation strictPositions offset args_strictness args_strictness_index
# (at_type, offset)
= addStrictnessToType strictPositions (at_annotation == AN_Strict) at_type offset
= ({arg & at_annotation = at_annotation, at_type = at_type}, offset)
instance addStrictness Annotation where
addStrictness info annotation offset
# offset
= checkStrictness info wasStrict offset
# (strictAdded, offset)
= nextBit info offset
| strictAdded
| wasStrict
= addStrictnessToType strictPositions is_strict at_type offset
= ({arg & at_type=at_type}, offset,args_strictness)
addStrictnessAnnotation info offset args_strictness args_strictness_index
# wasStrict = arg_is_strict args_strictness_index args_strictness
# offset
= checkStrictness info wasStrict offset
# (strictAdded, offset)
= nextBit info offset
| strictAdded
| wasStrict
= abort "backendinterface, addStrictness: already strict"
// otherwise
= (AN_Strict, offset)
// otherwise
= (annotation, offset)
where
wasStrict
= annotation == AN_Strict
# args_strictness = add_strictness args_strictness_index args_strictness
= (True, offset,args_strictness)
// otherwise
= (wasStrict, offset,args_strictness)
addStrictnessToType :: StrictnessInfo Bool Type Int -> (Type, Int)
addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_name,type_arity} args) offset
addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_index={glob_object,glob_module}} args) offset
# offset
= checkType strictPositions isTuple offset
| isTuple && isStrict
# (args, offset)
= addStrictness strictPositions args offset
= (TA ident args, offset)
# (args, offset,args_strictness)
= addStrictness strictPositions args offset NotStrict 0
| is_not_strict args_strictness
= (TA ident args, offset)
= (TAS ident args args_strictness, offset)
// otherwise
= (type, offset)
where
// FIXME: don't match on name but use predef info
isTuple
= type_name.id_name == "_Tuple" +++ toString type_arity
= glob_module==cPredefinedModuleIndex && (glob_object>=PD_Arity2TupleTypeIndex && glob_object<=PD_Arity32TupleTypeIndex)
addStrictnessToType strictPositions isStrict type=:(TAS ident=:{type_index={glob_object,glob_module}} args strictness) offset
# offset
= checkType strictPositions isTuple offset
| isTuple && isStrict
# (args, offset,strictness)
= addStrictness strictPositions args offset strictness 0
= (TAS ident args strictness, offset)
// otherwise
= (type, offset)
where
isTuple
= glob_module==cPredefinedModuleIndex && (glob_object>=PD_Arity2TupleTypeIndex && glob_object<=PD_Arity32TupleTypeIndex)
addStrictnessToType strictPositions _ type offset
# offset
= checkType strictPositions False offset
......@@ -274,6 +294,8 @@ instance collectAttrVars TypeAttribute where
instance collectAttrVars Type where
collectAttrVars (TA _ types) collect
= collectAttrVars types collect
collectAttrVars (TAS _ types _) collect
= collectAttrVars types collect
collectAttrVars (type1 --> type2) collect
= collectAttrVars type1 (collectAttrVars type2 collect)
collectAttrVars (TArrow1 type) collect
......@@ -316,28 +338,54 @@ DictionaryToClassInfo iclModuleIndex iclModule dclModules :==
}
dictionariesToClasses :: DictionaryToClassInfo SymbolType -> SymbolType
dictionariesToClasses info type=:{st_args, st_arity, st_context=[]}
dictionariesToClasses info type=:{st_args, st_args_strictness, st_arity, st_context=[]}
# (reversedTypes, reversedContexts)
= dictionaryArgsToClasses info st_args ([], [])
# n_contexts = length reversedContexts
# new_st_args_strictness = remove_first_n_strictness_values n_contexts st_args_strictness
with
remove_first_n_strictness_values 0 s
= s
remove_first_n_strictness_values _ NotStrict
= NotStrict
remove_first_n_strictness_values n (Strict s)
| n<32
= Strict (((s>>1) bitand 0x7fffffff)>>(n-1))
= NotStrict
remove_first_n_strictness_values n (StrictList s l)
| n<32
# s2=case l of
Strict s -> s
StrictList s _ -> s
NotStrict -> 0
# s=(((s>>1) bitand 0x7fffffff)>>(n-1)) bitor (s2<<(32-n))
= StrictList s (remove_first_n_strictness_values n l)
= remove_first_n_strictness_values (n-32) l
= {type & st_args = reverse reversedTypes, st_context = reverse reversedContexts,
st_arity = st_arity - length reversedContexts}
st_arity = st_arity - n_contexts, st_args_strictness=new_st_args_strictness}
dictionaryArgsToClasses :: DictionaryToClassInfo [AType] ([AType], [TypeContext]) -> ([AType], [TypeContext])
dictionaryArgsToClasses info args result
= foldSt (dictionaryArgToClass info) args result
dictionaryArgToClass :: DictionaryToClassInfo AType ([AType], [TypeContext]) -> ([AType], [TypeContext])
dictionaryArgToClass info type=:{at_type=TA typeSymbol args} (reversedTypes, reversedContexts)
= case typeToClass info typeSymbol of
Yes klass
-> (reversedTypes, [context : reversedContexts])
with
context
= {tc_class = klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
No
-> ([type : reversedTypes], reversedContexts)
dictionaryArgToClass _ type (reversedTypes, reversedContexts)
= ([type : reversedTypes], reversedContexts)
where
dictionaryArgToClass :: DictionaryToClassInfo AType ([AType], [TypeContext]) -> ([AType], [TypeContext])
dictionaryArgToClass info type=:{at_type=TA typeSymbol args} (reversedTypes, reversedContexts)
= case typeToClass info typeSymbol of
Yes klass
-> (reversedTypes, [dictionary_to_context klass args : reversedContexts])
No
-> ([type : reversedTypes], reversedContexts)
dictionaryArgToClass info type=:{at_type=TAS typeSymbol args _} (reversedTypes, reversedContexts)
= case typeToClass info typeSymbol of
Yes klass
-> (reversedTypes, [dictionary_to_context klass args : reversedContexts])
No
-> ([type : reversedTypes], reversedContexts)
dictionaryArgToClass _ type (reversedTypes, reversedContexts)
= ([type : reversedTypes], reversedContexts)
dictionary_to_context klass args
= {tc_class = klass, tc_types = [at_type \\ {at_type} <- args], tc_var = nilPtr}
typeToClass :: DictionaryToClassInfo TypeSymbIdent -> Optional (Global DefinedSymbol)
typeToClass info {type_name, type_arity, type_index={glob_module, glob_object}}
......
......@@ -81,6 +81,12 @@ where
= arg_type1 == arg_type2 && restype1 == restype2
equal_constructor_args (TA tc1 types1) (TA tc2 types2)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TA tc1 types1) (TAS tc2 types2 _)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TAS tc1 types1 _) (TA tc2 types2)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TAS tc1 types1 _) (TAS tc2 types2 _)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TB tb1) (TB tb2)
= tb1 == tb2
equal_constructor_args (type1 :@: types1) (type2 :@: types2)
......@@ -236,6 +242,9 @@ where
where
compare_arguments (TB tb1) (TB tb2) = tb1 =< tb2
compare_arguments (TA tc1 _) (TA tc2 _) = tc1 =< tc2
compare_arguments (TA tc1 _) (TAS tc2 _ _) = tc1 =< tc2
compare_arguments (TAS tc1 _ _) (TA tc2 _) = tc1 =< tc2
compare_arguments (TAS tc1 _ _) (TAS tc2 _ _) = tc1 =< tc2
compare_arguments _ _ = Equal
smallerOrEqual :: !Type !Type -> CompareValue
......@@ -251,6 +260,21 @@ smallerOrEqual t1 t2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (TA tc1 args1) (TAS tc2 args2 _)
# cmp_app_symb = tc1 =< tc2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (TAS tc1 args1 _) (TA tc2 args2)
# cmp_app_symb = tc1 =< tc2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (TAS tc1 args1 _) (TAS tc2 args2 _)
# cmp_app_symb = tc1 =< tc2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (l1 --> r1) (l2 --> r2)
# cmp_app_symb = l1 =< l2
| cmp_app_symb==Equal
......
......@@ -106,7 +106,14 @@ where
_
-> (type_defs, main_dcl_type_defs, type_heaps, error)
try_to_expand_synonym_type pos type=:{at_type = TA {type_name,type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error)
try_to_expand_synonym_type pos type=:{at_type = TA {type_index={glob_object,glob_module}} types} attribute (type_defs, type_heaps, error)
= try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
try_to_expand_synonym_type pos type=:{at_type = TAS {type_index={glob_object,glob_module}} types _} attribute (type_defs, type_heaps, error)
= try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
try_to_expand_synonym_type pos type attribute (type_defs, type_heaps, error)
= (No, type_defs, type_heaps, error)
try_to_expand_synonym_type_for_TA glob_object glob_module types pos type attribute type_defs type_heaps error
# (used_td=:{td_rhs}, type_defs) = type_defs![glob_module, glob_object]
= case td_rhs of
SynType {at_type}
......@@ -117,8 +124,6 @@ where
-> (No, type_defs, type_heaps, error)
_
-> (No, type_defs, type_heaps, error)
try_to_expand_synonym_type pos type attribute (type_defs, type_heaps, error)
= (No, type_defs, type_heaps, error)
try_to_expand_synonym_type_in_main_dcl main_dcl_module_index {gi_module,gi_index} (type_defs, main_dcl_type_defs, type_heaps, error)
| main_dcl_module_index == main_dcl_module_index && gi_index < size main_dcl_type_defs
......@@ -365,52 +370,58 @@ where
= (kind_info, cIsHyperStrict, ({ conds & con_var_binds = [{vb_var = kind_info_ptr, vb_vars = form_tvs } : con_var_binds] },
{ as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap }))
analTypes_for_TA :: Ident Int Int Int [AType] !Bool !{#CommonDefs} ![KindInfoPtr] !Conditions !*AnalyseState
-> (!KindInfo, !TypeProperties, !(!Conditions, !*AnalyseState))
analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
# form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity
({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
| type_arity <= form_type_arity
# kind = kindArrowToKindInfo (drop type_arity tdi_kinds)
| tdi_properties bitand cIsAnalysed == 0
# (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
# (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
= (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_name type_appl_error as.as_error }))
where
anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
(kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
{uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error}
| is_type_var type
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
(conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
where
is_type_var {at_type = TV _}
= True
is_type_var _
= False
anal_types_of_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind (kindToKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error}
as = { as & as_kind_heap = uki_kind_heap, as_error = uki_error }
(other_type_props, conds_as) = anal_types_of_type_cons modules form_tvs types tks (conds, as)
= (combineTypeProperties type_props other_type_props, conds_as)
anal_types_of_type_cons modules form_tvs types tks conds_as
= abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks))
instance analTypes Type
where
analTypes has_root_attr modules form_tvs (TV tv) conds_as
= analTypes has_root_attr modules form_tvs tv conds_as
analTypes has_root_attr modules form_tvs type=:(TA {type_name,type_index={glob_module,glob_object},type_arity} types) (conds, as)
# form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity
({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object]
| type_arity <= form_type_arity
# kind = kindArrowToKindInfo (drop type_arity tdi_kinds)
| tdi_properties bitand cIsAnalysed == 0
# (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
# (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as)
= (kind, type_properties, conds_as)
= (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_name type_appl_error as.as_error }))
where
anal_types_of_rec_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
anal_types_of_rec_type_cons modules form_tvs [type : types] [(KindVar kind_info_ptr) : tvs] conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules [ kind_info_ptr : form_tvs ] type conds_as
(kind, as_kind_heap) = readPtr kind_info_ptr as_kind_heap
{uki_kind_heap, uki_error} = unifyKinds type_kind kind {uki_kind_heap = as_kind_heap, uki_error = as_error}
| is_type_var type
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
(conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
# (other_type_props, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tvs
({ conds & con_top_var_binds = [kind_info_ptr : conds.con_top_var_binds]}, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })
= (combineTypeProperties type_props other_type_props, conds_as)
where
is_type_var {at_type = TV _}
= True
is_type_var _
= False
anal_types_of_type_cons modules form_tvs [] _ conds_as
= (cIsHyperStrict, conds_as)
anal_types_of_type_cons modules form_tvs [type : types] [tk : tks] conds_as
# (type_kind, type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs type conds_as
{uki_kind_heap, uki_error} = unifyKinds type_kind (kindToKindInfo tk) {uki_kind_heap = as_kind_heap, uki_error = as_error}
as = { as & as_kind_heap = uki_kind_heap, as_error = uki_error }
(other_type_props, conds_as) = anal_types_of_type_cons modules form_tvs types tks (conds, as)
= (combineTypeProperties type_props other_type_props, conds_as)
anal_types_of_type_cons modules form_tvs types tks conds_as
= abort ("anal_types_of_type_cons (analtypes.icl)" ---> (types, tks))
= analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
analTypes has_root_attr modules form_tvs type=:(TAS {type_name,type_index={glob_module,glob_object},type_arity} types _) (conds, as)
= analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as
analTypes has_root_attr modules form_tvs (arg_type --> res_type) conds_as
# (arg_kind, arg_type_props, conds_as) = analTypes has_root_attr modules form_tvs arg_type conds_as
(res_kind, res_type_props, (conds, as=:{as_kind_heap,as_error})) = analTypes has_root_attr modules form_tvs res_type conds_as
......@@ -475,7 +486,7 @@ cDummyBool :== False
analTypesOfConstructor modules cons_defs [{ds_index}:conses] (conds, as=:{as_type_var_heap,as_kind_heap})
# {cons_exi_vars,cons_type} = cons_defs.[ds_index ]
(coercible, as_type_var_heap, as_kind_heap) = new_local_kind_variables cons_exi_vars (as_type_var_heap, as_kind_heap)
(cons_properties, conds_as) = anal_types_of_cons modules cons_type.st_args