diff options
-rw-r--r-- | MacLibraries/CleanCompilerLib | bin | 420416 -> 421281 bytes | |||
-rw-r--r-- | backend/Clean System Files/backend_library | 3 | ||||
-rw-r--r-- | backend/backend.dcl | 10 | ||||
-rw-r--r-- | backend/backend.icl | 22 | ||||
-rw-r--r-- | backend/backendinterface.dcl | 2 | ||||
-rw-r--r-- | backend/backendinterface.icl | 342 | ||||
-rw-r--r-- | backendC/CleanCompilerSources/backend.c | 70 | ||||
-rw-r--r-- | backendC/CleanCompilerSources/backend.h | 12 | ||||
-rw-r--r-- | backendC/CleanCompilerSources/sa.c | 222 | ||||
-rw-r--r-- | backendC/CleanCompilerSources/syntax_tree_types.h | 12 | ||||
-rw-r--r-- | backendC/backend.link | 3 | ||||
-rw-r--r-- | backendC/backend.rc | 2 | ||||
-rw-r--r-- | coclmaindll/backend.dll | bin | 288768 -> 289792 bytes | |||
-rw-r--r-- | frontend/frontend.dcl | 7 | ||||
-rw-r--r-- | frontend/frontend.icl | 17 | ||||
-rw-r--r-- | frontend/syntax.dcl | 1 | ||||
-rw-r--r-- | frontend/syntax.icl | 1 | ||||
-rw-r--r-- | main/compile.icl | 31 |
18 files changed, 695 insertions, 62 deletions
diff --git a/MacLibraries/CleanCompilerLib b/MacLibraries/CleanCompilerLib Binary files differindex 7c3bc25..c33a275 100644 --- a/MacLibraries/CleanCompilerLib +++ b/MacLibraries/CleanCompilerLib diff --git a/backend/Clean System Files/backend_library b/backend/Clean System Files/backend_library index 780b1b4..6eb2ebe 100644 --- a/backend/Clean System Files/backend_library +++ b/backend/Clean System Files/backend_library @@ -1,6 +1,7 @@ backend.dll BEGetVersion BEInit +BECloseFiles BEFree BEArg BEDeclareModules @@ -120,5 +121,7 @@ BEExportField BEExportFunction BEDefineImportedObjsAndLibs BESetMainDclModuleN +BEStrictPositions +BECopyInts BEDeclareDynamicTypeSymbol BEDynamicTempTypeSymbol diff --git a/backend/backend.dcl b/backend/backend.dcl index 932338d..9730e6a 100644 --- a/backend/backend.dcl +++ b/backend/backend.dcl @@ -42,6 +42,8 @@ BEGetVersion :: (!Int,!Int,!Int); // void BEGetVersion (int* current,int* oldestDefinition,int* oldestImplementation); BEInit :: !Int !UWorld -> (!BackEnd,!UWorld); // BackEnd BEInit (int argc); +BECloseFiles :: !BackEnd -> BackEnd; +// void BECloseFiles (); BEFree :: !BackEnd !UWorld -> UWorld; // void BEFree (BackEnd backEnd); BEArg :: !String !BackEnd -> BackEnd; @@ -280,13 +282,17 @@ BEDefineImportedObjsAndLibs :: !BEStringListP !BEStringListP !BackEnd -> BackEnd // void BEDefineImportedObjsAndLibs (BEStringListP objs,BEStringListP libs); BESetMainDclModuleN :: !Int !BackEnd -> BackEnd; // void BESetMainDclModuleN (int main_dcl_module_n_parameter); +BEStrictPositions :: !Int !BackEnd -> (!Int,!Int,!BackEnd); +// void BEStrictPositions (int functionIndex,int* bits,int** positions); +BECopyInts :: !Int !Int !Int -> Int; +// int BECopyInts (int cLength,int* ints,int* cleanArray); BEDeclareDynamicTypeSymbol :: !Int !Int !BackEnd -> BackEnd; // void BEDeclareDynamicTypeSymbol (int typeIndex,int moduleIndex); BEDynamicTempTypeSymbol :: !BackEnd -> (!BESymbolP,!BackEnd); // BESymbolP BEDynamicTempTypeSymbol (); -kBEVersionCurrent:==0x02000215; +kBEVersionCurrent:==0x02000216; kBEVersionOldestDefinition:==0x02000213; -kBEVersionOldestImplementation:==0x02000215; +kBEVersionOldestImplementation:==0x02000216; kBEDebug:==1; kPredefinedModuleIndex:==1; BENoAnnot:==0; diff --git a/backend/backend.icl b/backend/backend.icl index 05ac802..3f914cb 100644 --- a/backend/backend.icl +++ b/backend/backend.icl @@ -51,6 +51,12 @@ BEInit a0 a1 = code { }; // BackEnd BEInit (int argc); +BECloseFiles :: !BackEnd -> BackEnd; +BECloseFiles a0 = code { + ccall BECloseFiles ":V:I" +}; +// void BECloseFiles (); + BEFree :: !BackEnd !UWorld -> UWorld; BEFree a0 a1 = code { ccall BEFree "I:V:I" @@ -765,6 +771,18 @@ BESetMainDclModuleN a0 a1 = code { }; // void BESetMainDclModuleN (int main_dcl_module_n_parameter); +BEStrictPositions :: !Int !BackEnd -> (!Int,!Int,!BackEnd); +BEStrictPositions a0 a1 = code { + ccall BEStrictPositions "I:VII:I" +}; +// void BEStrictPositions (int functionIndex,int* bits,int** positions); + +BECopyInts :: !Int !Int !Int -> Int; +BECopyInts a0 a1 a2 = code { + ccall BECopyInts "III:I" +}; +// int BECopyInts (int cLength,int* ints,int* cleanArray); + BEDeclareDynamicTypeSymbol :: !Int !Int !BackEnd -> BackEnd; BEDeclareDynamicTypeSymbol a0 a1 a2 = code { ccall BEDeclareDynamicTypeSymbol "II:V:I" @@ -776,9 +794,9 @@ BEDynamicTempTypeSymbol a0 = code { ccall BEDynamicTempTypeSymbol ":I:I" }; // BESymbolP BEDynamicTempTypeSymbol (); -kBEVersionCurrent:==0x02000215; +kBEVersionCurrent:==0x02000216; kBEVersionOldestDefinition:==0x02000213; -kBEVersionOldestImplementation:==0x02000215; +kBEVersionOldestImplementation:==0x02000216; kBEDebug:==1; kPredefinedModuleIndex:==1; BENoAnnot:==0; diff --git a/backend/backendinterface.dcl b/backend/backendinterface.dcl index 20dde99..b380398 100644 --- a/backend/backendinterface.dcl +++ b/backend/backendinterface.dcl @@ -5,4 +5,4 @@ definition module backendinterface import frontend -backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files) +backEndInterface :: !{#Char} [{#Char}] !ListTypesOption !{#Char} !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files) diff --git a/backend/backendinterface.icl b/backend/backendinterface.icl index d16fb84..504e19f 100644 --- a/backend/backendinterface.icl +++ b/backend/backendinterface.icl @@ -8,7 +8,7 @@ import StdEnv import frontend import backend import backendpreprocess, backendsupport, backendconvert -import RWSDebug, Version +import Version checkVersion :: VersionsCompatability *File -> (!Bool, !*File) checkVersion VersionsAreCompatible errorFile @@ -22,8 +22,8 @@ checkVersion VersionObservedIsTooOld errorFile = fwrites "[Backend] the back end library is too old\n" errorFile = (False, errorFile) -backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files) -backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_icl,fe_components} main_dcl_module_n var_heap attrHeap errorFile files +backEndInterface :: !{#Char} [{#Char}] !ListTypesOption !{#Char} !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*AttrVarHeap !*File !*Files -> (!Bool, !*VarHeap, !*AttrVarHeap, !*File, !*Files) +backEndInterface outputFileName commandLineArgs listTypes typesPath predef_symbols syntaxTree=:{fe_icl,fe_components,fe_dcls} main_dcl_module_n var_heap attrHeap errorFile files # (observedCurrent, observedOldestDefinition, observedOldestImplementation) = BEGetVersion observedVersion = @@ -61,6 +61,342 @@ backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_i = backEndConvertModules predef_symbols syntaxTree main_dcl_module_n varHeap attrHeap backEnd # (success, backEnd) = BEGenerateCode outputFileName backEnd + # backEnd + = BECloseFiles backEnd + # (attrHeap, files, backEnd) + // FIXME: should be type file + = optionallyPrintFunctionTypes listTypes typesPath (DictionaryToClassInfo main_dcl_module_n fe_icl fe_dcls) fe_components fe_icl.icl_functions attrHeap files backEnd # backEndFiles = BEFree backEnd backEndFiles = (backEndFiles == 0 && success, var_heap, attrHeap, errorFile, files) +import typesupport + +optionallyPrintFunctionTypes :: ListTypesOption {#Char} DictionaryToClassInfo {!Group} {#FunDef} *AttrVarHeap *Files !*BackEnd -> (*AttrVarHeap, *Files, *BackEnd) +optionallyPrintFunctionTypes {lto_listTypesKind, lto_showAttributes} typesPath info components functions attrHeap files backEnd + | lto_listTypesKind == ListTypesStrictExports || lto_listTypesKind == ListTypesAll + # (opened, typesFile, files) + = fopen typesPath FAppendText files + | not opened + = abort ("couldn't open types file \"" +++ typesPath +++ "\"\n") + # (attrHeap, typesFile, backEnd) + = printFunctionTypes (lto_listTypesKind == ListTypesAll) lto_showAttributes info components functions attrHeap typesFile backEnd + # (closed, files) + = fclose typesFile files + | not closed + = abort ("couldn't close types file \"" +++ typesPath +++ "\"\n") + = (attrHeap, files, backEnd) + // otherwise + = (attrHeap, files, backEnd) + +printFunctionTypes :: Bool Bool DictionaryToClassInfo {!Group} {#FunDef} *AttrVarHeap *File *BackEnd -> (*AttrVarHeap, *File, *BackEnd) +printFunctionTypes all attr info components functions attrHeap file backEnd + = foldSt (printFunctionType all attr info) [(index, functions.[index]) \\ (_, index) <- functionIndices] (attrHeap, file, backEnd) + where + functionIndices + = flatten [[(componentIndex, member) \\ member <- group.group_members] \\ group <-: components & componentIndex <- [1..]] + +printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap, *File, *BackEnd) -> (*AttrVarHeap, *File, *BackEnd) +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) + # (strictnessAdded, type, backEnd) + = addStrictnessFromBackEnd functionIndex fun_symb.id_name backEnd type + | not strictnessAdded && not all + = (attrHeap, file, backEnd) + // FIXME: shouldn't have to repair the invariant here + # (type, attrHeap) + = collectSymbolTypeAttrVars type attrHeap + # type + = dictionariesToClasses info type + # (type, attrHeap) + = beautifulizeAttributes type attrHeap + # file + = file <<< fun_symb <<< " :: " + <:: ({ form_properties = (if attr cAttributed 0) bitor cAnnotated, form_attr_position = No }, type, Yes initialTypeVarBeautifulizer) <<< '\n' + = (attrHeap, file, backEnd) + +addStrictnessFromBackEnd :: Int {#Char} *BackEnd SymbolType -> (Bool, SymbolType, *BackEnd) +addStrictnessFromBackEnd functionIndex functionName backEnd type + # (bitSize, strictPositionsC, backEnd) + = BEStrictPositions functionIndex backEnd + | bitSize == 0 // short cut + = (False, type, backEnd) + # strictPositions + = copyInts ((bitSize+31)/32) strictPositionsC // assumes 32 bit ints + # strictnessInfo + = {si_robust_encoding = False, si_positions = strictPositions, si_size = bitSize, si_name = functionName} + offset + = 0 + # (robust, offset) + = nextBit strictnessInfo offset + strictnessInfo + = {strictnessInfo & si_robust_encoding = robust} + # (anyStrictnessAdded, offset) + = nextBit strictnessInfo offset + # (type, offset) + = addStrictness strictnessInfo type offset + # type + = checkFinalOffset strictnessInfo offset type + = (anyStrictnessAdded, type, backEnd) + +:: StrictnessInfo = + { si_size :: !Int + , si_positions :: !LargeBitvect + , si_name :: {#Char} + , si_robust_encoding :: !Bool + } + +class addStrictness a :: !StrictnessInfo !a Int -> (!a, !Int) + +nextBit :: StrictnessInfo Int -> (Bool, Int) +nextBit {si_size, si_positions, si_robust_encoding} offset + | offset < si_size + = (bitvectSelect offset si_positions, offset+1) + // otherwise + | si_robust_encoding + = abort "backendinterface, nextBit: bit vector too small" + // otherwise + = (False, offset) + +checkStrictness :: StrictnessInfo Bool Int -> Int +checkStrictness info=:{si_robust_encoding} wasStrict offset + | si_robust_encoding + # (bit, offset) + = nextBit info offset + | bit <> wasStrict + = abort "backendinterface, checkStrictness: wrong info for strictness annotation" + = offset + // otherwise + = offset + +checkType :: StrictnessInfo Bool Int -> Int +checkType info=:{si_robust_encoding} isTuple offset + | si_robust_encoding + # (bit, offset) + = nextBit info offset + | bit <> isTuple + = abort "backendinterface, checkType: wrong type" + = offset + // otherwise + = offset + +checkFinalOffset :: StrictnessInfo Int a -> a +checkFinalOffset info=:{si_size, si_robust_encoding} offset value + | offset < si_size || (si_robust_encoding && offset > si_size) + = abort "backendinterface, checkFinalOffset: wrong offset" + // 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 + +instance addStrictness AType where + addStrictness strictPositions arg=:{at_annotation, at_type} offset + # (at_annotation, offset) + = addStrictness strictPositions at_annotation offset + # (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 + = abort "backendinterface, addStrictness: already strict" + // otherwise + = (AN_Strict, offset) + // otherwise + = (annotation, offset) + where + wasStrict + = annotation == AN_Strict + +addStrictnessToType :: StrictnessInfo Bool Type Int -> (Type, Int) +addStrictnessToType strictPositions isStrict type=:(TA ident=:{type_name,type_arity} args) offset + # offset + = checkType strictPositions isTuple offset + | isTuple && isStrict + # (args, offset) + = addStrictness strictPositions args offset + = (TA ident args, offset) + // otherwise + = (type, offset) + where + // FIXME: don't match on name but use predef info + isTuple + = type_name.id_name == "_Tuple" +++ toString type_arity +addStrictnessToType strictPositions _ type offset + # offset + = checkType strictPositions False offset + = (type, offset) + +collectSymbolTypeAttrVars :: SymbolType *AttrVarHeap -> (SymbolType, *AttrVarHeap) +collectSymbolTypeAttrVars type=:{st_attr_vars, st_result, st_args} attrVarHeap + # attrVarHeap + = foldSt markAttrVarCollected st_attr_vars attrVarHeap + # (st_attr_vars, attrVarHeap) + = collectAttrVars st_result (collectAttrVars st_args (st_attr_vars, attrVarHeap)) + = ({type & st_attr_vars = st_attr_vars}, attrVarHeap) + +/* maybe should collect st_vars as well (these are not used currently) */ +class collectAttrVars a :: a ([AttributeVar], *AttrVarHeap) -> ([AttributeVar], *AttrVarHeap) + +instance collectAttrVars AType where + collectAttrVars {at_attribute, at_type} collect + = collectAttrVars at_attribute (collectAttrVars at_type collect) + +instance collectAttrVars TypeAttribute where + collectAttrVars (TA_Var attrVar) collect + = collectAttrVars attrVar collect + collectAttrVars (TA_RootVar attrVar) collect + = collectAttrVars attrVar collect + collectAttrVars (TA_List _ attribute) collect + = collectAttrVars attribute collect + collectAttrVars (TA_Locked attribute) collect + = collectAttrVars attribute collect + collectAttrVars _ collect + = collect + +instance collectAttrVars Type where + collectAttrVars (TA _ types) collect + = collectAttrVars types collect + collectAttrVars (type1 --> type2) collect + = collectAttrVars type1 (collectAttrVars type2 collect) + collectAttrVars (TArrow1 type) collect + = collectAttrVars type collect + collectAttrVars (_ :@: types) collect + = collectAttrVars types collect + collectAttrVars (TFA _ type) collect + = collectAttrVars type collect + collectAttrVars _ collect + = collect + +instance collectAttrVars AttributeVar where + collectAttrVars attrVar=:{av_info_ptr} (attrVars, attrVarHeap) + # (info, attrVarHeap) + = readPtr av_info_ptr attrVarHeap + = case info of + AVI_Collected + -> (attrVars, attrVarHeap) + _ + -> ([attrVar : attrVars], markAttrVarCollected attrVar attrVarHeap) + +instance collectAttrVars [a] | collectAttrVars a where + collectAttrVars l collect + = foldSt collectAttrVars l collect + +markAttrVarCollected :: AttributeVar *AttrVarHeap -> *AttrVarHeap +markAttrVarCollected {av_info_ptr} attrVarHeap + = writePtr av_info_ptr AVI_Collected attrVarHeap + +:: DictionaryToClassInfo = + { dtci_iclModuleIndex :: Int + , dtci_iclModule :: IclModule + , dtic_dclModules :: {#DclModule} + } + +DictionaryToClassInfo iclModuleIndex iclModule dclModules :== + { dtci_iclModuleIndex = iclModuleIndex + , dtci_iclModule = iclModule + , dtic_dclModules = dclModules + } + +dictionariesToClasses :: DictionaryToClassInfo SymbolType -> SymbolType +dictionariesToClasses info type=:{st_args, st_arity, st_context=[]} + # (reversedTypes, reversedContexts) + = dictionaryArgsToClasses info st_args ([], []) + = {type & st_args = reverse reversedTypes, st_context = reverse reversedContexts, + st_arity = st_arity - length reversedContexts} + +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) + +typeToClass :: DictionaryToClassInfo TypeSymbIdent -> Optional (Global DefinedSymbol) +typeToClass info {type_name, type_arity, type_index={glob_module, glob_object}} + = case typeIndexToClassIndex info glob_module glob_object of + Yes classIndex + -> Yes {glob_module=glob_module, glob_object = {ds_ident = type_name, ds_arity = type_arity, ds_index = glob_object}} + No + -> No + where + /* + This how the types are organised (#classes == #dictionaries) + + com_classes + +--------(1)-------+--------(2)-------+ + | dcl classes | icl classes | + +------------------+------------------+ + nDclClasses nIclClasses + + com_type_defs + +-----------+--------(1)-------+-----------+--------(2)-------+ + | dcl types | dcl dictionaries | icl types | icl dictionaries | + +-----------+------------------+-----------+------------------+ + nDclTypes nIclTypes + */ + typeIndexToClassIndex :: DictionaryToClassInfo Int Int -> Optional Int + typeIndexToClassIndex {dtci_iclModuleIndex, dtci_iclModule, dtic_dclModules} moduleIndex typeIndex + | moduleIndex <> dtci_iclModuleIndex || typeIndex < nDclTypes + = toClassIndex typeIndex nDclTypes nDclClasses 0 + // otherwise + = toClassIndex (typeIndex-nDclTypes) (nIclTypes-nDclTypes) (nIclClasses-nDclClasses) nDclClasses + where + dclModule + = dtic_dclModules.[moduleIndex] + nDclTypes + = size dclModule.dcl_common.com_type_defs + nDclClasses + = size dclModule.dcl_common.com_class_defs + nIclTypes + = size dtci_iclModule.icl_common.com_type_defs + nIclClasses + = size dtci_iclModule.icl_common.com_class_defs + + toClassIndex :: Int Int Int Int -> Optional Int + toClassIndex typeIndex nTypes nClasses offset + | classIndex < 0 + = No + // otherwise + = Yes (classIndex + offset) + where + classIndex + = typeIndex - (nTypes - nClasses) + +copyInts :: !Int !Int -> {#Int} +copyInts length cArray + = code { + push_b 0 + create_array_ INT 0 1 + + push_a 0 + ccall BECopyInts "IIA-I" + pop_b 1 + } diff --git a/backendC/CleanCompilerSources/backend.c b/backendC/CleanCompilerSources/backend.c index c375a1d..74e2b3b 100644 --- a/backendC/CleanCompilerSources/backend.c +++ b/backendC/CleanCompilerSources/backend.c @@ -731,6 +731,7 @@ BESpecialArrayFunctionSymbol (BEArrayFunKind arrayFunKind, int functionIndex, in newTypeAlt->type_alt_lhs = BENormalTypeNode (newFunctionSymbol, lhsArgs); newTypeAlt->type_alt_rhs = rhs; + newTypeAlt->type_alt_strict_positions = NULL; newIdent->ident_symbol = newFunctionSymbol; newIdent->ident_name = functionName; @@ -820,6 +821,7 @@ CreateLocallyDefinedFunction (int index, char ** abcCode, TypeArgs lhsArgs, Type typeAlt->type_alt_attr_equations = NULL; /* used in PrintType */ typeAlt->type_alt_lhs = BENormalTypeNode (functionSymbol, lhsArgs); typeAlt->type_alt_rhs = rhsType; + typeAlt->type_alt_strict_positions = NULL; BERule (functionIndex, BEIsNotACaf, typeAlt, ruleAlt); @@ -1509,6 +1511,7 @@ BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs, BEUniVarEquations attributeEquation alt->type_alt_type_context = NULL; /* used in PrintType */ alt->type_alt_attr_equations = attributeEquations; /* used in PrintType */ + alt->type_alt_strict_positions = NULL; return (alt); } /* BETypeAlt */ @@ -3381,6 +3384,57 @@ BEExportFunction (int dclFunctionIndex, int iclFunctionIndex) dclDef->sdef_dcl_icl = iclDef; } /* BEExportFunction */ +void +BEStrictPositions (int functionIndex, int *bits, int **positions) +{ + BEModuleP module; + SymbolP functionSymbol; + SymbDef functionDefinition; + ImpRules rule; + TypeAlts ruleType; + StrictPositionsP strict_positions; + + Assert ((unsigned int) main_dcl_module_n < gBEState.be_nModules); + module = &gBEState.be_modules [main_dcl_module_n]; + + Assert ((unsigned int) functionIndex < module->bem_nFunctions); + functionSymbol = &module->bem_functions [functionIndex]; + + Assert (functionSymbol->symb_kind == definition); + functionDefinition = functionSymbol->symb_def; + + Assert (functionDefinition->sdef_kind == IMPRULE); + rule = functionDefinition->sdef_rule; + + ruleType = rule->rule_type; + Assert (ruleType != NULL); + + strict_positions = ruleType->type_alt_strict_positions; + + Assert (strict_positions != NULL); + + *bits = strict_positions->sp_size; + *positions = strict_positions->sp_bits; +} /* BEStrictPositions */ + +int +BECopyInts (int cLength, int *ints, int *cleanArray) +{ + int cleanLength, truncate; + + cleanLength = cleanArray [-2]; + + truncate = cleanLength < cLength; + if (truncate) + cLength = cleanLength; + + memcpy (cleanArray, ints, cLength * sizeof (int)); + + Assert (!truncate); + + return (!truncate); +} /* BECopyInts */ + static void CheckBEEnumTypes (void) { @@ -3623,6 +3677,17 @@ BEInit (int argc) } /* BEInit */ void +BECloseFiles (void) +{ + if (StdErrorReopened) + fclose (StdError); + StdErrorReopened = False; + if (StdOutReopened) + fclose (StdOut); + StdOutReopened = False; +} /* BECloseFiles */ + +void BEFree (BackEnd backEnd) { Assert (backEnd == (BackEnd) &gBEState); @@ -3633,10 +3698,7 @@ BEFree (BackEnd backEnd) Assert (gBEState.be_initialised); gBEState.be_initialised = False; - if (StdErrorReopened) - fclose (StdError); - if (StdOutReopened) - fclose (StdOut); + BECloseFiles (); } /* BEFree */ // temporary hack diff --git a/backendC/CleanCompilerSources/backend.h b/backendC/CleanCompilerSources/backend.h index 8f80be5..d690ce8 100644 --- a/backendC/CleanCompilerSources/backend.h +++ b/backendC/CleanCompilerSources/backend.h @@ -1,7 +1,7 @@ /* version info */ // increment this for every release -# define kBEVersionCurrent 0x02000215 +# define kBEVersionCurrent 0x02000216 // change this to the same value as kBEVersionCurrent if the new release is // not upward compatible (for example when a function is added) @@ -9,7 +9,7 @@ // change this to the same value as kBEVersionCurrent if the new release is // not downward compatible (for example when a function is removed) -# define kBEVersionOldestImplementation 0x02000215 +# define kBEVersionOldestImplementation 0x02000216 # define kBEDebug 1 @@ -178,6 +178,9 @@ Clean (BEGetVersion :: (Int, Int, Int)) BackEnd BEInit (int argc); Clean (BEInit :: Int UWorld -> (BackEnd, UWorld)) +void BECloseFiles (void); +Clean (BECloseFiles :: BackEnd -> BackEnd) + void BEFree (BackEnd backEnd); Clean (BEFree :: BackEnd UWorld -> UWorld) @@ -541,6 +544,11 @@ Clean (BEDefineImportedObjsAndLibs :: BEStringListP BEStringListP BackEnd -> Bac void BESetMainDclModuleN (int main_dcl_module_n_parameter); Clean (BESetMainDclModuleN :: Int BackEnd -> BackEnd) +void BEStrictPositions (int functionIndex, int *bits, int **positions); +Clean (BEStrictPositions :: Int BackEnd -> (Int, Int, BackEnd)) + +int BECopyInts (int cLength, int *ints, int *cleanArray); + // temporary hack void BEDeclareDynamicTypeSymbol (int typeIndex, int moduleIndex); Clean (BEDeclareDynamicTypeSymbol :: Int Int BackEnd -> BackEnd) diff --git a/backendC/CleanCompilerSources/sa.c b/backendC/CleanCompilerSources/sa.c index 4a75d97..ea8deab 100644 --- a/backendC/CleanCompilerSources/sa.c +++ b/backendC/CleanCompilerSources/sa.c @@ -2849,50 +2849,182 @@ static void ConvertStateInfoToStrictInfos (TypeAlts rule_type_alts, unsigned ari InitStrictInfo (result, HnfStrict); } -static void UpdateStateInfoWithStrictInfo (TypeNode node, StrictInfo *s,Bool *strict_added_p,Bool *warning) +#if CLEAN2 + +/* + Encoding for strictness information: + + The strictness information that is found by the strictness + analyser is encoded in a bit string. There are two encodings + + compact (but fragile): + 0 a (s)* trailing zeros are removed + + robust (but long): + 1 a (w s t)* + + a any strictness added + ()* repeated for each argument position, recursively + for strict (after sa) tuples + w argument was strict + s argument strictness added + t argument is tuple + + Example: + f :: ! a ( a, [a]) -> a // before sa + f :: ! a ! ( ! a, [a]) -> a // after sa + + compact 0 1 0 1 1 0 => 01011 (trailing zeros removed) + + robust 1 1 100 011 010 000 => 11100011010000 + + The bit string is represented by a bit count and an array of + ints (each 32 bits), where the least significant bit of an int + is the first bit in the bit string. +*/ + +#define StrictPositionsRobustEncoding 1 + +#define kMaxStrictPositions 1024 + +#if StrictPositionsRobustEncoding +# define kBitsPerStrictPosition 3 +#else +# define kBitsPerStrictPosition 1 +# endif + +#define kMaxStrictBits (2+kMaxStrictPositions*kBitsPerStrictPosition) +#define kBitsPerInt (sizeof (int)*8) +#define ceilingdiv(a, b) (((a)+(b)-1)/(b)) /* ceiling (a/b) */ +#define bits2ints(n) ceilingdiv(n, kBitsPerInt) + +static int strict_positions_last_one; +static StrictPositionsP strict_positions; + + +static void StrictPositionsClear (void) { - Bool is_strict_annotated; -#ifndef SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS - Bool local_strict_added; + int i, sizeInts; + + if (strict_positions == NULL) + { + int sizeBytes; - local_strict_added = False; + sizeInts = bits2ints(kMaxStrictPositions); + sizeBytes = sizeof (StrictPositionsS) + (sizeInts-1) * sizeof (int); + strict_positions = CompAlloc (sizeBytes); + + strict_positions->sp_size = 0; + } + + sizeInts = bits2ints (strict_positions->sp_size); + for (i = 0; i < sizeInts; i++) + strict_positions->sp_bits[i] = 0; + + strict_positions->sp_size = 0; + strict_positions_last_one = 0; +} + +static void StrictPositionsAddBit (Bool bit) +{ + int size; + StrictPositionsP positions; + + positions = strict_positions; + size = positions->sp_size; + + if (bit) + { + Assume (size < kMaxStrictPositions, "too many strict positions", "AddStrictPositions"); + + positions->sp_bits [size/kBitsPerInt] |= 1 << (size % kBitsPerInt); + strict_positions_last_one = size+1; + } + + positions->sp_size = size+1; +} + + +static StrictPositionsP StrictPositionsCopy (void) +{ + StrictPositionsP positions; + int sizeBits; + +#if StrictPositionsRobustEncoding + sizeBits = strict_positions->sp_size; +#else + sizeBits = strict_positions_last_one; #endif + Assume (size < kMaxStrictPositions, "too many strict positions", "StrictPositionsToInts"); + + if (sizeBits == 0) + { + static StrictPositionsS no_strict_postions = {0, {0}}; + + positions = &no_strict_postions; + } + else + { + int sizeInts, sizeBytes; + + sizeInts = bits2ints(sizeBits); + sizeBytes = sizeof (StrictPositionsS) + (sizeInts-1) * sizeof (int); + positions = CompAlloc (sizeBytes); + memcpy (positions, strict_positions, sizeBytes); + } + + return positions; +} + +#define StrictPositionsStrictAdded(is_strict) StrictPositionsAddBit (is_strict) + +#if StrictPositionsRobustEncoding +# define StrictPositionsWasStrict(is_strict_annotated) StrictPositionsAddBit (is_strict_annotated) +# define StrictPositionsType(is_tuple) StrictPositionsAddBit (is_tuple) +#else +# define StrictPositionsWasStrict(is_strict_annotated) +# define StrictPositionsType(is_tuple) +#endif + +#endif /* CLEAN2 */ + +static void UpdateStateInfoWithStrictInfo (TypeNode node, StrictInfo *s,Bool *strict_added_p,Bool *warning) +{ + Bool is_strict_annotated, is_strict, is_tuple, strict_added; + is_strict_annotated = node->type_node_annotation==StrictAnnot; - - if (IsTupleInfo (s)){ + is_tuple = IsTupleInfo (s); + is_strict = (is_tuple ? GetTupleStrictKind (s) : GetStrictKind (s, 0)) != NotStrict; + strict_added = !is_strict_annotated && is_strict; + +#if CLEAN2 + StrictPositionsWasStrict (is_strict_annotated); + StrictPositionsStrictAdded (strict_added); + StrictPositionsType (is_tuple); +#endif + + if (strict_added) { + node->type_node_annotation=StrictAnnot; + *strict_added_p = True; + } + + if (is_strict_annotated && !is_strict && StrictChecks) + *warning = True; + + if (is_tuple && (is_strict || is_strict_annotated)){ unsigned arity = s->strict_arity; unsigned i; TypeArgs args = node->type_node_arguments; - - if (GetTupleStrictKind (s) == NotStrict){ - if (StrictChecks && is_strict_annotated) - *warning = True; - return; - } - - if (! is_strict_annotated){ - node->type_node_annotation=StrictAnnot; - *strict_added_p = True; - } - - for (i = 0; i < arity; i++, args = args->type_arg_next) -#ifdef SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS - UpdateStateInfoWithStrictInfo (args->type_arg_node,&GetTupleInfo (s,i),strict_added_p,warning); -#else - UpdateStateInfoWithStrictInfo (args->type_arg_node,&GetTupleInfo (s,i),&local_strict_added,warning); -#endif - } else { -#if 0 - printf ("%d %d %d\n",GetStrictKind (s, 0),GetStrictKind (s, 1),GetStrictKind (s, 2)); + + for (i = 0; i < arity; i++, args = args->type_arg_next) { +#ifndef SHOW_STRICT_EXPORTED_TUPLE_ELEMENTS + Bool local_strict_added; + + local_strict_added = False; + strict_added_p = &local_strict_added; #endif - if (GetStrictKind (s, 0) != NotStrict){ - if (!is_strict_annotated){ - node->type_node_annotation=StrictAnnot; - *strict_added_p = True; - } - } else if (StrictChecks && GetStrictKind (s, 0) == NotStrict && is_strict_annotated){ - *warning = True; + UpdateStateInfoWithStrictInfo (args->type_arg_node,&GetTupleInfo (s,i),strict_added_p,warning); } } } @@ -2908,8 +3040,26 @@ static void UpdateStateInfosWithStrictInfos (TypeAlts rule, unsigned arity, Stri /* do the arguments */ args = rule->type_alt_lhs->type_node_arguments; - for (i = 0; i < arity; i++, args = args->type_arg_next) +#if CLEAN2 + StrictPositionsClear (); + StrictPositionsAddBit (StrictPositionsRobustEncoding); + StrictPositionsAddBit (False); +#endif + + for (i = 0; i < arity; i++, args = args->type_arg_next) { UpdateStateInfoWithStrictInfo (args->type_arg_node,&strict_args[i], strict_added, warning); + } + +#if CLEAN2 + if (*strict_added) + { + Assume (strict_positions->sp_size > 2, "not enough bits", "UpdateStateInfosWithStrictInfos"); + Assume (strict_positions_last_one > 2, "not enough bits", "UpdateStateInfosWithStrictInfos"); + strict_positions->sp_bits [0] |= 1 << 1; + } + + rule->type_alt_strict_positions = StrictPositionsCopy (); +#endif /* the result has no sense at the moment */ } diff --git a/backendC/CleanCompilerSources/syntax_tree_types.h b/backendC/CleanCompilerSources/syntax_tree_types.h index ad6cebc..24e1987 100644 --- a/backendC/CleanCompilerSources/syntax_tree_types.h +++ b/backendC/CleanCompilerSources/syntax_tree_types.h @@ -427,16 +427,26 @@ typedef struct uni_var_equats struct uni_var_equats * uve_next; } * UniVarEquations; +#if CLEAN2 +STRUCT (strict_positions, StrictPositions) +{ + int sp_size; /* size in bits */ + int sp_bits [1]; /* variable size */ +}; +#endif + typedef struct type_alt { TypeNode type_alt_lhs; TypeNode type_alt_rhs; UniVarEquations type_alt_attr_equations; TypeContext type_alt_type_context; - struct uni_var_admin * type_alt_attr_vars; unsigned type_alt_line; +#ifdef CLEAN2 + StrictPositionsP type_alt_strict_positions; +#endif } TypeAlt; typedef struct cons_var_list diff --git a/backendC/backend.link b/backendC/backend.link index 1363626..9c3498d 100644 --- a/backendC/backend.link +++ b/backendC/backend.link @@ -1,5 +1,6 @@ /EXPORT: BEGetVersion /EXPORT: BEInit +/EXPORT: BECloseFiles /EXPORT: BEFree /EXPORT: BEArg /EXPORT: BEDeclareModules @@ -119,5 +120,7 @@ /EXPORT: BEExportFunction /EXPORT: BEDefineImportedObjsAndLibs /EXPORT: BESetMainDclModuleN +/EXPORT: BEStrictPositions +/EXPORT: BECopyInts /EXPORT: BEDeclareDynamicTypeSymbol /EXPORT: BEDynamicTempTypeSymbol diff --git a/backendC/backend.rc b/backendC/backend.rc index 16b1c8f..489cd59 100644 --- a/backendC/backend.rc +++ b/backendC/backend.rc @@ -14,7 +14,7 @@ # define kFileFlags VS_FF_DEBUG | VS_FF_PRERELEASE # define kFileFlagsMask VS_FF_DEBUG | VS_FF_PRERELEASE -# define kFileVersionString "2.0.d.12" +# define kFileVersionString "2.0.d.16" VS_VERSION_INFO VERSIONINFO FILEVERSION kFileVersion diff --git a/coclmaindll/backend.dll b/coclmaindll/backend.dll Binary files differindex 352a89c..5d6e544 100644 --- a/coclmaindll/backend.dll +++ b/coclmaindll/backend.dll diff --git a/frontend/frontend.dcl b/frontend/frontend.dcl index 2810e58..4b23a06 100644 --- a/frontend/frontend.dcl +++ b/frontend/frontend.dcl @@ -28,5 +28,12 @@ import checksupport, transform, overloading | FrontEndPhaseConvertModules | FrontEndPhaseAll +:: ListTypesKind = ListTypesNone | ListTypesInferred | ListTypesStrictExports | ListTypesAll +:: ListTypesOption = + { lto_showAttributes :: Bool + , lto_listTypesKind :: ListTypesKind + } +instance == ListTypesKind + frontEndInterface :: !FrontEndOptions !Ident !SearchPaths !{#DclModule} !*{#*{#FunDef}} !(Optional Bool) !*PredefinedSymbols !*HashTable (ModTimeFunction *Files) !*Files !*File !*File !*File (!Optional !*File) !*Heaps -> ( !Optional *FrontEndSyntaxTree,!*{#*{#FunDef}},!{#DclModule},!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional !*File, !*Heaps) diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 2c5fe9a..d2c4a3d 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -396,4 +396,21 @@ where show_dcl_function {ft_symb, ft_type} file = file <<< ft_symb <<< " :: " <<< ft_type <<< "\n" + +:: ListTypesKind = ListTypesNone | ListTypesInferred | ListTypesStrictExports | ListTypesAll +:: ListTypesOption = + { lto_showAttributes :: Bool + , lto_listTypesKind :: ListTypesKind + } +instance == ListTypesKind where + (==) ListTypesNone ListTypesNone + = True + (==) ListTypesInferred ListTypesInferred + = True + (==) ListTypesStrictExports ListTypesStrictExports + = True + (==) ListTypesAll ListTypesAll + = True + (==) _ _ + = False
\ No newline at end of file diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 32fc53e..1669b95 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -909,6 +909,7 @@ cNonRecursiveAppl :== False | AVI_Used | AVI_Count !Int /* auxiliary used in module typesupport */ | AVI_SequenceNumber !Int // RWS + | AVI_Collected // RWS :: AttrVarInfoPtr :== Ptr AttrVarInfo :: AttrVarHeap :== Heap AttrVarInfo diff --git a/frontend/syntax.icl b/frontend/syntax.icl index e60a9c3..0d4957e 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -888,6 +888,7 @@ cNotVarNumber :== -1 | AVI_Used | AVI_Count !Int /* auxiliary used in module typesupport */ | AVI_SequenceNumber !Int // RWS + | AVI_Collected // RWS :: AttrVarInfoPtr :== Ptr AttrVarInfo :: AttrVarHeap :== Heap AttrVarInfo diff --git a/main/compile.icl b/main/compile.icl index bd114d6..2a4b557 100644 --- a/main/compile.icl +++ b/main/compile.icl @@ -1,3 +1,6 @@ +/* + module owner: Ronny Wichers Schreur +*/ implementation module compile import StdEnv @@ -8,6 +11,7 @@ import portToNewSyntax import compilerSwitches //import RWSDebug + :: CoclOptions = { moduleName:: {#Char} , pathName ::{#Char} @@ -16,6 +20,7 @@ import compilerSwitches , outPath:: {#Char} , outMode:: Int , searchPaths:: SearchPaths + , listTypes :: ListTypesOption , compile_for_dynamics :: !Bool , support_generics :: !Bool , compile_with_fusion :: !Bool @@ -30,6 +35,7 @@ InitialCoclOptions = , outPath= "out" , outMode= FWriteText , searchPaths= {sp_locations = [], sp_paths = []} + , listTypes = {lto_showAttributes = True, lto_listTypesKind = ListTypesNone} , compile_for_dynamics = False , support_generics = False , compile_with_fusion = False @@ -90,6 +96,14 @@ parseCommandLine [arg1=:"-fusion":args] options parseCommandLine ["-generics":args] options // enable generics = parseCommandLine args (SwitchGenerics {options & compile_with_generics = True} options) +parseCommandLine ["-lattr":args] options + = parseCommandLine args {options & listTypes.lto_showAttributes = False} +parseCommandLine ["-lt":args] options + = parseCommandLine args {options & listTypes.lto_listTypesKind = ListTypesInferred} +parseCommandLine ["-lset":args] options + = parseCommandLine args {options & listTypes.lto_listTypesKind = ListTypesStrictExports} +parseCommandLine ["-lat":args] options + = parseCommandLine args {options & listTypes.lto_listTypesKind = ListTypesAll} parseCommandLine [arg : args] options | arg.[0] == '-' # (args,modules,options)= parseCommandLine args options @@ -159,19 +173,14 @@ compile_modules [module_:modules] n_compiles cocl_options args_without_modules c # (ok,cache,files) = compileModule cocl_options (args_without_modules++[module_]) cache files; | ok -/* - # heaps = { hp_var_heap = newHeap, hp_expression_heap = newHeap, hp_type_heaps = { th_vars = newHeap, th_attrs = newHeap }} - # (predef_symbols, hash_table) = buildPredefinedSymbols newHashTable - = compile_modules modules 0 cocl_options args_without_modules {} {} predef_symbols hash_table heaps files; -*/ = compile_modules modules (n_compiles+1) cocl_options args_without_modules cache files; - + // otherwise = (ok,cache,files); compile_modules [] n_compiles cocl_options args_without_modules cache files = (True,cache,files); compileModule :: CoclOptions [{#Char}] *DclCache *Files -> (!Bool,!*DclCache,!*Files) -compileModule options commandLineArgs {dcl_modules,functions_and_macros,predef_symbols,hash_table,heaps} files +compileModule options backendArgs {dcl_modules,functions_and_macros,predef_symbols,hash_table,heaps} files # (opened, error, files) = fopen options.errorPath options.errorMode files | not opened @@ -184,9 +193,11 @@ compileModule options commandLineArgs {dcl_modules,functions_and_macros,predef_s = openTclFile options options.pathName files # (io, files) = stdio files -// (moduleIdent, hash_table) = putIdentInHashTable options.moduleName IC_Module hash_table # ({boxed_ident=moduleIdent}, hash_table) = putIdentInHashTable options.moduleName IC_Module hash_table - # list_inferred_types = if (isMember "-lt" commandLineArgs) (Yes (not (isMember "-lattr" commandLineArgs))) No + # list_inferred_types + = if (options.listTypes.lto_listTypesKind == ListTypesInferred) + (Yes options.listTypes.lto_showAttributes) + No # (optionalSyntaxTree,cached_functions_and_macros,cached_dcl_mods,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out,tcl_file,heaps) = frontEndInterface {feo_up_to_phase=FrontEndPhaseAll,feo_generics=options.compile_with_generics,feo_fusion=options.compile_with_fusion} moduleIdent options.searchPaths dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table fmodificationtime files error io out tcl_file heaps # unique_copy_of_predef_symbols={predef_symbol\\predef_symbol<-:predef_symbols} @@ -220,7 +231,7 @@ compileModule options commandLineArgs {dcl_modules,functions_and_macros,predef_s <<< options.moduleName <<< '\n') error # (success, var_heap, attrHeap, error, files) - = backEndInterface outputPath (map appendRedirection commandLineArgs) predef_symbols syntaxTree main_dcl_module_n var_heap attrHeap error files + = backEndInterface outputPath (map appendRedirection backendArgs) options.listTypes options.outPath predef_symbols syntaxTree main_dcl_module_n var_heap attrHeap error files -> (success,functions_and_macros,n_functions_and_macros_in_dcl_modules,var_heap,attrHeap, error, files) with appendRedirection arg |