diff options
| -rw-r--r-- | backend/backendconvert.icl | 215 | ||||
| -rw-r--r-- | backend/backendinterface.icl | 4 | ||||
| -rw-r--r-- | backend/backendpreprocess.dcl | 3 | ||||
| -rw-r--r-- | backend/backendpreprocess.icl | 61 | ||||
| -rw-r--r-- | frontend/check.dcl | 3 | ||||
| -rw-r--r-- | frontend/check.icl | 42 | ||||
| -rw-r--r-- | frontend/predef.dcl | 8 | ||||
| -rw-r--r-- | frontend/predef.icl | 27 | ||||
| -rw-r--r-- | frontend/transform.dcl | 4 | ||||
| -rw-r--r-- | frontend/transform.icl | 73 |
10 files changed, 355 insertions, 85 deletions
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl index ff5a95c..df366c9 100644 --- a/backend/backendconvert.icl +++ b/backend/backendconvert.icl @@ -305,7 +305,10 @@ backEndConvertModules predefs {fe_icl = fe_icl =: {icl_name, icl_functions, icl_ #! backEnd = adjustArrayFunctions predefs fe_arrayInstances icl_functions fe_dcls varHeap (backEnd -*-> "adjustArrayFunctions") #! (rules, backEnd) - = convertRules [(index, icl_functions.[index]) \\ (_, index) <- functionIndices] varHeap (backEnd -*-> "convertRules") +// MW was: = convertRules [(index, icl_functions.[index]) \\ (_, index) <- functionIndices] varHeap (backEnd -*-> "convertRules") + = convertRules predefs.[PD_DummyForStrictAliasFun].pds_ident + [(index, icl_functions.[index]) \\ (_, index) <- functionIndices] + varHeap (backEnd -*-> "convertRules") #! backEnd = BEDefineRules rules (backEnd -*-> "BEDefineRules") #! backEnd @@ -407,7 +410,11 @@ reshuffleTypes nIclTypes dclIclConversions be #! to` = if (to` >= nDclTypes) frm` to` = (swap frm` to` p, swap frm to p`, swapTypes frm to be) +/* MW changed into +class declareVars a :: a !(!Ident, !VarHeap) -> Backender +before it was: class declareVars a :: a !VarHeap -> Backender +non trivial changes are indicated with a comment instance declareVars [a] | declareVars a where declareVars :: [a] VarHeap -> Backender | declareVars a @@ -476,6 +483,88 @@ instance declareVars BackendBody where declareVars {bb_args, bb_rhs} varHeap = declareVars bb_args varHeap o` declareVars bb_rhs varHeap +*/ +:: DeclVarsInput :== (!Ident, !VarHeap) + +class declareVars a :: a !DeclVarsInput -> Backender + +instance declareVars [a] | declareVars a where + declareVars :: [a] !DeclVarsInput -> Backender | declareVars a + declareVars list dvInput + = foldState (flip declareVars dvInput) list + +instance declareVars (Ptr VarInfo) where + declareVars varInfoPtr (_, varHeap) + = declareVariable BELhsNodeId varInfoPtr "_var???" varHeap // +++ name + +instance declareVars FreeVar where + declareVars :: FreeVar !DeclVarsInput -> Backender + declareVars freeVar (_, varHeap) + = declareVariable BELhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap + +// MW this rule was changed non trivially +instance declareVars (Bind Expression FreeVar) where + declareVars :: (Bind Expression FreeVar) !DeclVarsInput -> Backender + declareVars {bind_src=App {app_symb, app_args=[Var _:_]}, bind_dst=freeVar} (aliasDummyId, varHeap) + | app_symb.symb_name==aliasDummyId + = identity // we have an alias. Don't declare the same variable twice + = declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap + declareVars {bind_dst=freeVar} (_, varHeap) + = declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap + +declareVariable :: Int (Ptr VarInfo) {#Char} !VarHeap -> Backender +declareVariable lhsOrRhs varInfoPtr name varHeap + = beDeclareNodeId (getVariableSequenceNumber varInfoPtr varHeap) lhsOrRhs name + +instance declareVars (Optional a) | declareVars a where + declareVars :: (Optional a) !DeclVarsInput -> Backender | declareVars a + declareVars (Yes x) dvInput + = declareVars x dvInput + declareVars No _ + = identity + +instance declareVars FunctionPattern where + declareVars :: FunctionPattern !DeclVarsInput -> Backender + declareVars (FP_Algebraic _ freeVars optionalVar) dvInput + = declareVars freeVars dvInput + o` declareVars optionalVar dvInput + declareVars (FP_Variable freeVar) dvInput + = declareVars freeVar dvInput + declareVars (FP_Basic _ optionalVar) dvInput + = declareVars optionalVar dvInput + declareVars FP_Empty dvInput + = identity + +instance declareVars Expression where + declareVars :: Expression !DeclVarsInput -> Backender + declareVars (Let {let_strict_binds, let_lazy_binds, let_expr}) dvInput + = declareVars let_strict_binds dvInput + o` declareVars let_lazy_binds dvInput + o` declareVars let_expr dvInput + declareVars (Conditional {if_then, if_else}) dvInput + = declareVars if_then dvInput + o` declareVars if_else dvInput +// MW here was a non trivial change + declareVars (AnyCodeExpr _ outParams _) (_, varHeap) + = foldState (declVar varHeap) outParams + where + declVar varHeap {bind_dst=freeVar} + = declareVariable BERhsNodeId freeVar.fv_info_ptr freeVar.fv_name.id_name varHeap + declareVars _ _ + = identity + +instance declareVars TransformedBody where + declareVars :: TransformedBody !DeclVarsInput -> Backender + declareVars {tb_args, tb_rhs} dvInput + = declareVars tb_args dvInput + o` declareVars tb_rhs dvInput + +instance declareVars BackendBody where + declareVars :: BackendBody !DeclVarsInput -> Backender + declareVars {bb_args, bb_rhs} dvInput + = declareVars bb_args dvInput + o` declareVars bb_rhs dvInput + :: ModuleIndex :== Index @@ -830,8 +919,12 @@ convertRules rules varHeap = foldl (flip beRules) beNoRules (map (flip convertRule varHeap) rules) */ +/* MW was convertRules :: [(Int, FunDef)] VarHeap *BackEnd -> (BEImpRuleP, *BackEnd) convertRules rules varHeap be +*/ +convertRules :: Ident [(Int, FunDef)] VarHeap *BackEnd -> (BEImpRuleP, *BackEnd) +convertRules aliasDummyId rules varHeap be # (null, be) = BENoRules be = convert rules varHeap null be @@ -842,14 +935,22 @@ convertRules rules varHeap be = (rulesP, be) convert [h:t] varHeap rulesP be # (ruleP, be) - = convertRule h varHeap be +// MW was = convertRule h varHeap be + = convertRule aliasDummyId h varHeap be # (rulesP, be) = BERules ruleP rulesP be = convert t varHeap rulesP be +/* MW was convertRule :: (Int,FunDef) VarHeap -> BEMonad BEImpRuleP convertRule (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb}) varHeap - = beRule index (cafness fun_kind) (convertTypeAlt index cIclModIndex (type /* ->> ("convertRule", fun_symb.id_name, index, type) */)) (convertFunctionBody index (positionToLineNumber fun_pos) body varHeap) +*/ +convertRule :: Ident (Int,FunDef) VarHeap -> BEMonad BEImpRuleP +convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_symb}) varHeap +// MW was: = beRule index (cafness fun_kind) (convertTypeAlt index cIclModIndex (type /* ->> ("convertRule", fun_symb.id_name, index, type) */)) (convertFunctionBody index (positionToLineNumber fun_pos) body varHeap) + = beRule index (cafness fun_kind) + (convertTypeAlt index cIclModIndex (type /* ->> ("convertRule", fun_symb.id_name, index, type) */)) + (convertFunctionBody index (positionToLineNumber fun_pos) aliasDummyId body varHeap) where cafness :: FunKind -> Int cafness (FK_Function _) @@ -869,9 +970,14 @@ convertRule (index, {fun_type=Yes type, fun_body=body, fun_pos, fun_kind, fun_sy positionToLineNumber _ = -1 +/* MW was convertFunctionBody :: Int Int FunctionBody VarHeap -> BEMonad BERuleAltP convertFunctionBody functionIndex lineNumber (BackendBody bodies) varHeap = convertBackendBodies functionIndex lineNumber bodies varHeap +*/ +convertFunctionBody :: Int Int Ident FunctionBody VarHeap -> BEMonad BERuleAltP +convertFunctionBody functionIndex lineNumber aliasDummyId (BackendBody bodies) varHeap + = convertBackendBodies functionIndex lineNumber aliasDummyId bodies varHeap convertTypeAlt :: Int ModuleIndex SymbolType -> BEMonad BETypeAltP convertTypeAlt functionIndex moduleIndex symbol=:{st_result} @@ -951,37 +1057,54 @@ convertTypeArgs :: [AType] -> BEMonad BETypeArgP convertTypeArgs args = foldr (beTypeArgs o convertAnnotTypeNode) beNoTypeArgs args +/* MW was convertBackendBodies :: Int Int [BackendBody] VarHeap -> BEMonad BERuleAltP convertBackendBodies functionIndex lineNumber bodies varHeap = foldr (beRuleAlts o (flip (convertBackendBody functionIndex lineNumber)) varHeap) beNoRuleAlts bodies +*/ +convertBackendBodies :: Int Int Ident [BackendBody] VarHeap -> BEMonad BERuleAltP +convertBackendBodies functionIndex lineNumber aliasDummyId bodies varHeap + = foldr (beRuleAlts o (flip (convertBackendBody functionIndex lineNumber aliasDummyId)) varHeap) + beNoRuleAlts bodies +/* MW was convertBackendBody :: Int Int BackendBody VarHeap -> BEMonad BERuleAltP convertBackendBody functionIndex lineNumber body=:{bb_args, bb_rhs=ABCCodeExpr instructions inline} varHeap +*/ +convertBackendBody :: Int Int Ident BackendBody VarHeap -> BEMonad BERuleAltP +convertBackendBody functionIndex lineNumber aliasDummyId body=:{bb_args, bb_rhs=ABCCodeExpr instructions inline} varHeap = beNoNodeDefs ==> \noNodeDefs - -> declareVars body varHeap +// MW was -> declareVars body varHeap + -> declareVars body (aliasDummyId, varHeap) o` beCodeAlt lineNumber (convertLhsNodeDefs bb_args noNodeDefs varHeap) (convertBackendLhs functionIndex bb_args varHeap) (beAbcCodeBlock inline (convertStrings instructions)) -convertBackendBody functionIndex lineNumber body=:{bb_args, bb_rhs=AnyCodeExpr inParams outParams instructions} varHeap +// MW was:convertBackendBody functionIndex lineNumber body=:{bb_args, bb_rhs=AnyCodeExpr inParams outParams instructions} varHeap +convertBackendBody functionIndex lineNumber aliasDummyId body=:{bb_args, bb_rhs=AnyCodeExpr inParams outParams instructions} varHeap = beNoNodeDefs ==> \noNodeDefs - -> declareVars body varHeap +// MW was -> declareVars body varHeap + -> declareVars body (aliasDummyId, varHeap) o` beCodeAlt lineNumber (convertLhsNodeDefs bb_args noNodeDefs varHeap) (convertBackendLhs functionIndex bb_args varHeap) (beAnyCodeBlock (convertCodeParameters inParams varHeap) (convertCodeParameters outParams varHeap) (convertStrings instructions)) -convertBackendBody functionIndex lineNumber body=:{bb_args, bb_rhs} varHeap +// MW was:convertBackendBody functionIndex lineNumber body=:{bb_args, bb_rhs} varHeap +convertBackendBody functionIndex lineNumber aliasDummyId body=:{bb_args, bb_rhs} varHeap = beNoNodeDefs ==> \noNodeDefs - -> declareVars body varHeap +// MW was -> declareVars body varHeap + -> declareVars body (aliasDummyId, varHeap) o` beRuleAlt lineNumber (convertLhsNodeDefs bb_args noNodeDefs varHeap) (convertBackendLhs functionIndex bb_args varHeap) - (convertRhsNodeDefs bb_rhs varHeap) +// MW was: (convertRhsNodeDefs bb_rhs varHeap) + (convertRhsNodeDefs aliasDummyId bb_rhs varHeap) (convertRhsStrictNodeIds bb_rhs varHeap) - (convertRootExpr bb_rhs varHeap) +// MW was: (convertRootExpr bb_rhs varHeap) + (convertRootExpr aliasDummyId bb_rhs varHeap) convertStrings :: [{#Char}] -> BEMonad BEStringListP convertStrings strings @@ -1049,6 +1172,7 @@ convertVars :: [VarInfoPtr] VarHeap -> BEMonad BEArgP convertVars vars varHeap = foldr (beArgs o flip convertVarPtr varHeap) beNoArgs vars +/* MW was convertRootExpr :: Expression VarHeap -> BEMonad BENodeP convertRootExpr (Let {let_expr}) varHeap = convertRootExpr let_expr varHeap @@ -1057,24 +1181,41 @@ convertRootExpr (Conditional {if_cond=cond, if_then=then, if_else=Yes else}) var where convertConditional :: Expression Expression Expression VarHeap -> BEMonad BENodeP convertConditional cond then else varHeap +*/ +convertRootExpr :: Ident Expression VarHeap -> BEMonad BENodeP +convertRootExpr aliasDummyId (Let {let_expr}) varHeap + = convertRootExpr aliasDummyId let_expr varHeap +convertRootExpr aliasDummyId (Conditional {if_cond=cond, if_then=then, if_else=Yes else}) varHeap + = convertConditional aliasDummyId cond then else varHeap + where + convertConditional :: Ident Expression Expression Expression VarHeap -> BEMonad BENodeP + convertConditional aliasDummyId cond then else varHeap = beGuardNode (convertExpr cond varHeap) - (convertRhsNodeDefs then varHeap) +// MW was: (convertRhsNodeDefs then varHeap) + (convertRhsNodeDefs aliasDummyId then varHeap) (convertRhsStrictNodeIds then varHeap) - (convertRootExpr then varHeap) - (convertRhsNodeDefs else varHeap) +// MW was: (convertRootExpr then varHeap) + (convertRootExpr aliasDummyId then varHeap) +// MW was: (convertRhsNodeDefs else varHeap) + (convertRhsNodeDefs aliasDummyId else varHeap) (convertRhsStrictNodeIds else varHeap) - (convertRootExpr else varHeap) -convertRootExpr (Conditional {if_cond=cond, if_then=then, if_else=No}) varHeap +// MW was: (convertRootExpr else varHeap) + (convertRootExpr aliasDummyId else varHeap) +// MW was:convertRootExpr (Conditional {if_cond=cond, if_then=then, if_else=No}) varHeap +convertRootExpr aliasDummyId (Conditional {if_cond=cond, if_then=then, if_else=No}) varHeap = beGuardNode (convertExpr cond varHeap) - (convertRhsNodeDefs then varHeap) +// MW was: (convertRhsNodeDefs then varHeap) + (convertRhsNodeDefs aliasDummyId then varHeap) (convertRhsStrictNodeIds then varHeap) - (convertRootExpr then varHeap) +// MW was: (convertRootExpr then varHeap) + (convertRootExpr aliasDummyId then varHeap) beNoNodeDefs beNoStrictNodeIds (beNormalNode (beBasicSymbol BEFailSymb) beNoArgs) -convertRootExpr expr varHeap +// MW was:convertRootExpr expr varHeap +convertRootExpr _ expr varHeap = convertExpr expr varHeap // RWS +++ rewrite @@ -1103,15 +1244,42 @@ defineLhsNodeDef freeVar pattern nodeDefs varHeap (beNodeDef (getVariableSequenceNumber freeVar.fv_info_ptr varHeap) (convertPattern pattern varHeap)) (return nodeDefs) +/* MW was collectNodeDefs :: Expression -> [Bind Expression FreeVar] collectNodeDefs (Let {let_strict_binds, let_lazy_binds}) = let_strict_binds ++ let_lazy_binds -collectNodeDefs _ +*/ +collectNodeDefs :: Ident Expression -> [Bind Expression FreeVar] +collectNodeDefs aliasDummyId (Let {let_strict_binds, let_lazy_binds}) +// MW was: = let_strict_binds ++ let_lazy_binds + = filterStrictAlias let_strict_binds let_lazy_binds + where + filterStrictAlias [] let_lazy_binds + = let_lazy_binds + filterStrictAlias [strict_bind=:{bind_src=App app}:strict_binds] let_lazy_binds + | app.app_symb.symb_name==aliasDummyId + // the compiled source was a strict alias like "#! x = y" + = case hd app.app_args of + Var _ + // the node is still such an alias and must be ignored + -> filterStrictAlias strict_binds let_lazy_binds + hd_app_args + // the node is not an alias anymore: remove just the _dummyForStrictAlias call + -> [{ strict_bind & bind_src = hd_app_args } : filterStrictAlias strict_binds let_lazy_binds] + filterStrictAlias [strict_bind:strict_binds] let_lazy_binds + = [strict_bind: filterStrictAlias strict_binds let_lazy_binds] +// MW was:collectNodeDefs _ +collectNodeDefs _ _ = [] +/* MW was convertRhsNodeDefs :: Expression VarHeap -> BEMonad BENodeDefP convertRhsNodeDefs expr varHeap = convertNodeDefs (collectNodeDefs expr) varHeap +*/ +convertRhsNodeDefs :: Ident Expression VarHeap -> BEMonad BENodeDefP +convertRhsNodeDefs aliasDummyId expr varHeap + = convertNodeDefs (collectNodeDefs aliasDummyId expr) varHeap convertNodeDef :: !(Bind Expression FreeVar) VarHeap -> BEMonad BENodeDefP convertNodeDef {bind_src=expr, bind_dst=freeVar} varHeap @@ -1305,10 +1473,19 @@ convertVar varInfo varHeap = beNodeId (getVariableSequenceNumber varInfo varHeap) getVariableSequenceNumber :: VarInfoPtr VarHeap -> Int +/* MW was getVariableSequenceNumber varInfoPtr varHeap # (VI_SequenceNumber sequenceNumber) = sreadPtr varInfoPtr varHeap = sequenceNumber +*/ +getVariableSequenceNumber varInfoPtr varHeap + # vi = sreadPtr varInfoPtr varHeap + = case vi of + VI_SequenceNumber sequenceNumber + -> sequenceNumber + VI_Alias {var_info_ptr} + -> getVariableSequenceNumber var_info_ptr varHeap markExports :: DclModule {#ClassDef} {#CheckedTypeDef} {#ClassDef} {#CheckedTypeDef} (Optional {#Int}) -> Backender markExports {dcl_conversions = Yes conversionTable} dclClasses dclTypes iclClasses iclTypes (Yes functionConversions) diff --git a/backend/backendinterface.icl b/backend/backendinterface.icl index d491e99..5638946 100644 --- a/backend/backendinterface.icl +++ b/backend/backendinterface.icl @@ -44,7 +44,9 @@ backEndInterface outputFileName commandLineArgs predefs syntaxTree errorFile fil | not compatible = (False, errorFile, files) # varHeap - = backendPreprocess functionIndices syntaxTree.fe_icl syntaxTree.fe_varHeap +// MW was: = backendPreprocess functionIndices syntaxTree.fe_icl syntaxTree.fe_varHeap + = backendPreprocess predefs.[PD_DummyForStrictAliasFun].pds_ident functionIndices + syntaxTree.fe_icl syntaxTree.fe_varHeap with functionIndices = flatten [[member \\ member <- group.group_members] \\ group <-: syntaxTree.fe_components] diff --git a/backend/backendpreprocess.dcl b/backend/backendpreprocess.dcl index 2da8b05..1935be9 100644 --- a/backend/backendpreprocess.dcl +++ b/backend/backendpreprocess.dcl @@ -4,4 +4,5 @@ import checksupport // assign sequence numbers to all variables in the syntax tree -backendPreprocess :: ![Index] !IclModule !*VarHeap -> *VarHeap +// MW was:backendPreprocess :: ![Index] !IclModule !*VarHeap -> *VarHeap +backendPreprocess :: !Ident ![Index] !IclModule !*VarHeap -> *VarHeap diff --git a/backend/backendpreprocess.icl b/backend/backendpreprocess.icl index 72242f0..749a536 100644 --- a/backend/backendpreprocess.icl +++ b/backend/backendpreprocess.icl @@ -7,11 +7,18 @@ import Heap import backendsupport import RWSDebug +/* MW was backendPreprocess :: ![Index] !IclModule !*VarHeap -> *VarHeap -backendPreprocess functionIndices iclModule varHeap +backendPreprocess predefSymblos functionIndices iclModule varHeap = preprocess [iclModule.icl_functions.[i] \\ i <- functionIndices] varHeap - -class preprocess a :: a -> Preprocessor +*/ +backendPreprocess :: !Ident ![Index] !IclModule !*VarHeap -> *VarHeap +backendPreprocess aliasDummyId functionIndices iclModule varHeap + = preprocess aliasDummyId + [iclModule.icl_functions.[i] \\ i <- functionIndices] varHeap + +// MW was class preprocess a :: a -> Preprocessor +class preprocess a :: !Ident a -> Preprocessor :: Preprocessor :== *PreprocessState -> *PreprocessState :: PreprocessState @@ -23,31 +30,52 @@ instance preprocess {#a} | preprocess a & ArrayElem a where /*2.0 instance preprocess {#a} | preprocess a & Array {#} a where 0.2*/ +/* MW was preprocess array = foldStateA preprocess array +*/ + preprocess aliasDummyId array + = foldStateA (preprocess aliasDummyId) array instance preprocess [a] | preprocess a where +/* MW was preprocess list = foldState preprocess list +*/ + preprocess aliasDummyId list + = foldState (preprocess aliasDummyId) list // +++ this assigns sequence numbers per function, should be per alternative and move to backendconvert instance preprocess FunDef where +/* MW was preprocess funDef = fromSequencerToPreprocessor (sequence funDef.fun_body) +*/ + preprocess aliasDummyId funDef + = fromSequencerToPreprocessor aliasDummyId (sequence funDef.fun_body) class sequence a :: a -> Sequencer :: Sequencer :== *SequenceState -> *SequenceState :: SequenceState - = {ss_sequenceNumber :: !Int, ss_varHeap :: .VarHeap} + = {ss_sequenceNumber :: !Int, ss_varHeap :: .VarHeap, ss_aliasDummyId :: !Ident} +// MW added ss_aliasDummyId (remove it if you don't like it, Ronny) +/* MW was toSequenceState varHeap :== {ss_sequenceNumber = 0, ss_varHeap = varHeap} +*/ +toSequenceState aliasDummyId varHeap + :== {ss_sequenceNumber = 0, ss_varHeap = varHeap, ss_aliasDummyId = aliasDummyId} fromSequenceState sequenceState :== sequenceState.ss_varHeap +/* MW was fromSequencerToPreprocessor sequencer :== toSequenceState +*/ +fromSequencerToPreprocessor aliasDummyId sequencer + :== toSequenceState aliasDummyId o` sequencer o` fromSequenceState @@ -100,7 +128,8 @@ instance sequence Expression where = sequence exp o` sequence selections sequence (AnyCodeExpr _ outParams _) - = sequence outParams +// MW was: = sequence outParams + = foldState (\{bind_dst}->sequence bind_dst) outParams sequence _ = identity @@ -112,7 +141,27 @@ instance sequence Selection where sequence (DictionarySelection dictionaryVar dictionarySelections _ index) = sequence index -instance sequence (Bind a b) | sequence b where +// MW was:instance sequence (Bind a b) | sequence b where +instance sequence (Bind Expression FreeVar) where +// MW.. PD_DummyForStrictAliasFun + sequence {bind_src=App app , bind_dst} + = sequence` app bind_dst + where + sequence` {app_symb, app_args} bind_dst sequenceState=:{ss_aliasDummyId} + | app_symb.symb_name==ss_aliasDummyId + // the compiled source was a strict alias like "#! x = y" + = case hd app_args of + Var bound_var=:{var_info_ptr} + # (vi, ss_varHeap) = readPtr var_info_ptr sequenceState.ss_varHeap + non_alias_bound_var = case vi of + VI_SequenceNumber _ -> bound_var + VI_Alias alias_bound_var-> alias_bound_var + ss_varHeap = writePtr bind_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap + -> { sequenceState & ss_varHeap = ss_varHeap } + _ + -> sequence bind_dst sequenceState + = sequence bind_dst sequenceState +// ..MW sequence bind = sequence bind.bind_dst diff --git a/frontend/check.dcl b/frontend/check.dcl index 3c13324..e69603a 100644 --- a/frontend/check.dcl +++ b/frontend/check.dcl @@ -15,7 +15,6 @@ convertIndex :: !Index !Index !(Optional ConversionTable) -> !Index determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps -> (!SymbolType, !Specials, !*TypeHeaps) - -arrayFunOffsetToPD_IndexTable :: !{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !{#MemberDef}, !v:{#PredefinedSymbol}) +arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x] makeElemTypeOfArrayFunctionStrict :: !SymbolType !Index !{# Index} -> SymbolType diff --git a/frontend/check.icl b/frontend/check.icl index c8cda08..975ebec 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -2197,14 +2197,14 @@ where | bind_dst == fv_info_ptr # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> (Let { let_lazy_binds = [], let_strict_binds = [ + -> (Let { let_strict_binds = [], let_lazy_binds= [ { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}], let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) # (var_expr_ptr1, expr_heap) = newPtr EI_Empty expr_heap (var_expr_ptr2, expr_heap) = newPtr EI_Empty expr_heap (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> (Let { let_lazy_binds = [], let_strict_binds = [ + -> (Let { let_strict_binds = [], let_lazy_binds= [ { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr1 }, bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}, { bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr2 }, @@ -2215,10 +2215,11 @@ where -> (result_expr, var_store, expr_heap, opt_dynamics, cs) # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> (Let { let_lazy_binds = [], let_strict_binds = + -> (Let { let_strict_binds = [], let_lazy_binds= [{ bind_src = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}], let_expr = result_expr, let_info_ptr = let_expr_ptr}, var_store, expr_heap, opt_dynamics, cs) + transform_pattern_into_cases (AP_Algebraic cons_symbol type_index args opt_var) fun_arg result_expr var_store expr_heap opt_dynamics cs # (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr var_store expr_heap opt_dynamics cs type_symbol = {glob_module = cons_symbol.glob_module, glob_object = type_index} @@ -2335,13 +2336,14 @@ checkFunctions mod_index level from_index to_index fun_defs e_info heaps cs checkMacros :: !Index !IndexRange !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState); checkMacros mod_index range fun_defs e_info=:{ef_is_macro_fun=ef_is_macro_fun_old} heaps cs - # (fun_defs, e_info, heaps=:{hp_var_heap, hp_expression_heap}, cs=:{cs_symbol_table,cs_error}) + # (fun_defs, e_info, heaps=:{hp_var_heap, hp_expression_heap}, cs=:{cs_symbol_table, cs_predef_symbols, cs_error}) = checkFunctions mod_index cGlobalScope range.ir_from range.ir_to fun_defs { e_info & ef_is_macro_fun=True } heaps cs (e_info=:{ef_modules}) = { e_info & ef_is_macro_fun=ef_is_macro_fun_old } + (pds_alias_dummy, cs_predef_symbols) = cs_predef_symbols![PD_DummyForStrictAliasFun] (fun_defs, ef_modules, hp_var_heap, hp_expression_heap, cs_symbol_table, cs_error) - = partitionateMacros range mod_index fun_defs ef_modules hp_var_heap hp_expression_heap cs_symbol_table cs_error + = partitionateMacros range mod_index pds_alias_dummy fun_defs ef_modules hp_var_heap hp_expression_heap cs_symbol_table cs_error = (fun_defs, { e_info & ef_modules = ef_modules }, {heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap}, - { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error }) + { cs & cs_symbol_table = cs_symbol_table, cs_predef_symbols = cs_predef_symbols, cs_error = cs_error }) checkInstanceBodies :: !IndexRange !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef},!*ExpressionInfo,!*Heaps, !*CheckState); checkInstanceBodies {ir_from, ir_to} fun_defs e_info heaps cs @@ -2670,8 +2672,9 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs = adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances icl_functions cs_predef_symbols (untransformed_fun_bodies, icl_functions) = copy_bodies icl_functions + (pds_alias_dummy, cs_predef_symbols) = cs_predef_symbols![PD_DummyForStrictAliasFun] (groups, icl_functions, dcl_modules, var_heap, expr_heap, cs_symbol_table, cs_error) - = partitionateAndLiftFunctions [icl_global_function_range, icl_instances] cIclModIndex icl_functions + = partitionateAndLiftFunctions [icl_global_function_range, icl_instances] cIclModIndex pds_alias_dummy icl_functions dcl_modules var_heap expr_heap cs_symbol_table cs_error icl_common = { icl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs, com_instance_defs = class_instances } @@ -2930,9 +2933,9 @@ check_needed_modules_are_imported mod_name extension cs=:{cs_needed_modules} cs_error = popErrorAdmin cs_error -> { cs & cs_error = cs_error } -arrayFunOffsetToPD_IndexTable :: !{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !{#MemberDef}, !v:{#PredefinedSymbol}) +arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x] arrayFunOffsetToPD_IndexTable member_defs predef_symbols - # nr_of_array_functions = size member_defs + #! nr_of_array_functions = size member_defs = iFoldSt offset_to_PD_index PD_CreateArrayFun (PD_CreateArrayFun + nr_of_array_functions) (createArray nr_of_array_functions NoIndex, member_defs, predef_symbols) where @@ -3063,26 +3066,26 @@ checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions h mem_inst <- memb_inst_defs & spec_types <-: all_spec_types ] ++ reverse rev_special_defs) } + com_instance_defs = dcl_common.com_instance_defs + com_instance_defs = { inst_def \\ inst_def <- [ inst_def \\ inst_def <-: com_instance_defs ] ++ new_class_instances } + + (com_member_defs, com_instance_defs, dcl_functions, cs) + = adjust_predefined_symbols mod_index dcl_common.com_member_defs com_instance_defs dcl_functions { cs & cs_error = cs_error } + e_info = { ef_type_defs = com_type_defs, ef_selector_defs = dcl_common.com_selector_defs, ef_class_defs = com_class_defs, - ef_cons_defs = dcl_common.com_cons_defs, ef_member_defs = dcl_common.com_member_defs, ef_modules = modules, + ef_cons_defs = dcl_common.com_cons_defs, ef_member_defs = com_member_defs, ef_modules = modules, ef_is_macro_fun = False } (icl_functions, e_info, heaps, cs) - = checkMacros mod_index dcl_macros icl_functions e_info heaps { cs & cs_error = cs_error } + = checkMacros mod_index dcl_macros icl_functions e_info heaps cs cs = check_needed_modules_are_imported mod_name ".dcl" cs - com_instance_defs = dcl_common.com_instance_defs - com_instance_defs = { inst_def \\ inst_def <- [ inst_def \\ inst_def <-: com_instance_defs ] ++ new_class_instances } - - (ef_member_defs, com_instance_defs, dcl_functions, cs) - = adjust_predefined_symbols mod_index e_info.ef_member_defs com_instance_defs dcl_functions cs - first_special_class_index = size com_instance_defs last_special_class_index = first_special_class_index + length new_class_instances dcl_common = { dcl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs, - com_instance_defs = com_instance_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = ef_member_defs } + com_instance_defs = com_instance_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs } (dcl_imported, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable imports [] cs.cs_symbol_table cs_symbol_table = removeDeclarationsFromSymbolTable dcl_defined cModuleScope cs_symbol_table @@ -3147,7 +3150,8 @@ where <=< adjust_predef_symbols PD_ListType PD_UnboxedArrayType mod_index STE_Type <=< adjust_predef_symbols PD_ConsSymbol PD_Arity32TupleSymbol mod_index STE_Constructor <=< adjust_predef_symbol PD_TypeCodeClass mod_index STE_Class - <=< adjust_predef_symbol PD_TypeCodeMember mod_index STE_Member) + <=< adjust_predef_symbol PD_TypeCodeMember mod_index STE_Member + <=< adjust_predef_symbol PD_DummyForStrictAliasFun mod_index STE_DclFunction) # (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdBool] | pre_mod.pds_def == mod_index = (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols} diff --git a/frontend/predef.dcl b/frontend/predef.dcl index 5c2a42c..66f032c 100644 --- a/frontend/predef.dcl +++ b/frontend/predef.dcl @@ -75,7 +75,6 @@ PD_TypeCodeClass :== 122 PD_TypeObjectType :== 124 PD_TypeConsSymbol :== 125 PD_unify :== 126 -// MV .. PD_coerce :== 127 PD_variablePlaceholder :== 128 PD_StdDynamics :== 129 @@ -83,8 +82,11 @@ PD_undo_indirections :== 130 PD_Start :== 131 -PD_NrOfPredefSymbols :== 132 -// .. MV +// MW.. +PD_DummyForStrictAliasFun :== 132 + +PD_NrOfPredefSymbols :== 133 +// ..MW GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2 GetTupleTypeIndex tup_arity :== PD_Arity2TupleType + tup_arity - 2 diff --git a/frontend/predef.icl b/frontend/predef.icl index 277896a..c28aa2d 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -73,7 +73,6 @@ PD_TypeCodeClass :== 122 PD_TypeObjectType :== 124 PD_TypeConsSymbol :== 125 PD_unify :== 126 -// MV .. PD_coerce :== 127 PD_variablePlaceholder :== 128 PD_StdDynamics :== 129 @@ -81,8 +80,11 @@ PD_undo_indirections :== 130 PD_Start :== 131 -PD_NrOfPredefSymbols :== 132 -// .. MV +// MW.. +PD_DummyForStrictAliasFun :== 132 + +PD_NrOfPredefSymbols :== 133 +// ..MW (<<=) infixl @@ -113,6 +115,7 @@ where <<= ("_list", PD_ListType) <<= ("_cons", PD_ConsSymbol) <<= ("_nil", PD_NilSymbol) <<= ("_array", PD_LazyArrayType) <<= ("_!array", PD_StrictArrayType) <<= ("_#array", PD_UnboxedArrayType) <<= ("_type_code", PD_TypeCodeMember) + <<= ("_dummyForStrictAlias", PD_DummyForStrictAliasFun) // MW++ where build_tuples tup_arity max_arity tables @@ -198,6 +201,7 @@ buildPredefinedModule pre_def_symbols (list_id, pre_def_symbols) = pre_def_symbols![PD_ListType] (unb_array_id, pre_def_symbols) = pre_def_symbols![PD_UnboxedArrayType] (pre_mod_symb, pre_def_symbols) = pre_def_symbols![PD_PredefinedModule] + (alias_dummy_symb, pre_def_symbols) = pre_def_symbols![PD_DummyForStrictAliasFun] // MW++ (cons_symb, pre_def_symbols) = new_defined_symbol PD_ConsSymbol 2 cConsSymbIndex pre_def_symbols (nil_symb, pre_def_symbols) = new_defined_symbol PD_NilSymbol 0 cNilSymbIndex pre_def_symbols pre_mod_id = pre_mod_symb.pds_ident @@ -220,12 +224,14 @@ buildPredefinedModule pre_def_symbols (unboxed_def, pre_def_symbols) = make_type_def PD_UnboxedArrayType [type_var] (AbstractType cIsHyperStrict) pre_def_symbols (type_defs, cons_defs, pre_def_symbols) = add_tuple_defs pre_mod_id MaxTupleArity [array_def,strict_def,unboxed_def] [] pre_def_symbols + alias_dummy_type = make_identity_fun_type alias_dummy_symb.pds_ident type_var // MW++ (class_def, member_def, pre_def_symbols) = make_TC_class_def pre_def_symbols = ({ mod_name = pre_mod_id, mod_type = MK_System, mod_imports = [], mod_imported_objects = [], mod_defs = { - def_types = [string_def, list_def : type_defs], def_constructors - = [ParsedConstructorToConsDef cons_def, ParsedConstructorToConsDef nil_def : cons_defs], def_selectors = [], def_classes = [class_def], - def_macros = { ir_from = 0, ir_to = 0 }, def_members = [member_def], def_funtypes = [], def_instances = [] }}, pre_def_symbols) + def_types = [string_def, list_def : type_defs], + def_constructors = [ParsedConstructorToConsDef cons_def, ParsedConstructorToConsDef nil_def : cons_defs], + def_selectors = [], def_classes = [class_def], def_macros = { ir_from = 0, ir_to = 0 }, def_members = [member_def], + def_funtypes = [alias_dummy_type], def_instances = [] }}, pre_def_symbols) where add_tuple_defs pre_mod_id tup_arity type_defs cons_defs pre_def_symbols | tup_arity >= 2 @@ -276,7 +282,14 @@ where = (class_def, member_def, pre_def_symbols) - +// MW.. + make_identity_fun_type alias_dummy_id type_var + # a = { at_attribute = TA_Anonymous, at_annotation = AN_Strict, at_type = TV type_var } + id_symbol_type = { st_vars = [], st_args = [a], st_arity = 1, st_result = a, st_context = [], + st_attr_vars = [], st_attr_env = [] } // !.a -> .a + = { ft_symb = alias_dummy_id, ft_arity = 1, ft_priority = NoPrio, ft_type = id_symbol_type, ft_pos = NoPos, + ft_specials = SP_None, ft_type_ptr = nilPtr } +// ..MW diff --git a/frontend/transform.dcl b/frontend/transform.dcl index 6d3a81c..43118c7 100644 --- a/frontend/transform.dcl +++ b/frontend/transform.dcl @@ -6,10 +6,10 @@ import syntax, checksupport { group_members :: ![Int] } -partitionateAndLiftFunctions :: ![IndexRange] !Index !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin +partitionateAndLiftFunctions :: ![IndexRange] !Index !PredefinedSymbol !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin -> (!*{! Group}, !*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) -partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin +partitionateMacros :: !IndexRange !Index !PredefinedSymbol !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin -> (!*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) :: UnfoldState = diff --git a/frontend/transform.icl b/frontend/transform.icl index abc067b..46caeb1 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -543,9 +543,9 @@ where NotChecked :== -1 -partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin +partitionateMacros :: !IndexRange !Index !PredefinedSymbol !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin -> (!*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) -partitionateMacros {ir_from,ir_to} mod_index fun_defs modules var_heap symbol_heap symbol_table error +partitionateMacros {ir_from,ir_to} mod_index alias_dummy fun_defs modules var_heap symbol_heap symbol_table error #! max_fun_nr = size fun_defs # partitioning_info = { pi_var_heap = var_heap, pi_symbol_heap = symbol_heap, pi_symbol_table = symbol_table, @@ -588,7 +588,7 @@ where es = { es_symbol_table = pi_symbol_table, es_var_heap = pi_var_heap, es_symbol_heap = pi_symbol_heap, es_error = setErrorAdmin identPos pi_error } (tb_args, tb_rhs, local_vars, fi_calls, macro_defs, modules, {es_symbol_table, es_var_heap, es_symbol_heap, es_error}) - = expandMacrosInBody [] body macro_defs mod_index modules es + = expandMacrosInBody [] body macro_defs mod_index alias_dummy modules es macro = { macro & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = local_vars }} = ({ macro_defs & [macro_index] = macro }, modules, @@ -607,9 +607,9 @@ where is_a_pattern_macro _ _ = False -partitionateAndLiftFunctions :: ![IndexRange] !Index !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin +partitionateAndLiftFunctions :: ![IndexRange] !Index !PredefinedSymbol !*{# FunDef} !u:{# DclModule} !*VarHeap !*ExpressionHeap !*SymbolTable !*ErrorAdmin -> (!*{! Group}, !*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) -partitionateAndLiftFunctions ranges mod_index fun_defs modules var_heap symbol_heap symbol_table error +partitionateAndLiftFunctions ranges mod_index alias_dummy fun_defs modules var_heap symbol_heap symbol_table error #! max_fun_nr = size fun_defs # partitioning_info = { pi_var_heap = var_heap, pi_symbol_heap = symbol_heap, pi_symbol_table = symbol_table, pi_error = error, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } @@ -687,7 +687,8 @@ where {fun_symb,fun_body = PartioningFunction body _, fun_info, fun_pos} = fun_def identPos = newPosition fun_symb fun_pos (tb_args, tb_rhs, fi_local_vars, fi_calls, fun_and_macro_defs, modules, es) - = expandMacrosInBody fun_info.fi_calls body fun_and_macro_defs mod_index modules { es & es_error = setErrorAdmin identPos es.es_error } + = expandMacrosInBody fun_info.fi_calls body fun_and_macro_defs mod_index alias_dummy modules + { es & es_error = setErrorAdmin identPos es.es_error } fun_def = { fun_def & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = fi_local_vars }} = ({ fun_and_macro_defs & [fun_index] = fun_def }, modules, es) @@ -732,13 +733,15 @@ where -> (fun_defs, symbol_table) -expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index modules es=:{es_symbol_table} +expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index alias_dummy modules es=:{es_symbol_table} # (prev_calls, fun_defs, es_symbol_table) = addFunctionCallsToSymbolTable fi_calls fun_defs es_symbol_table ([rhs:rhss], fun_defs, modules, (all_calls, es)) = expand cb_rhs fun_defs mod_index modules (prev_calls, { es & es_symbol_table = es_symbol_table }) (fun_defs, es_symbol_table) = removeFunctionCallsFromSymbolTable all_calls fun_defs es.es_symbol_table (merged_rhs, es_var_heap, es_symbol_heap, es_error) = mergeCases rhs rhss es.es_var_heap es.es_symbol_heap es.es_error - (new_rhs, new_args, local_vars, {cos_error, cos_var_heap, cos_symbol_heap}) = determineVariablesAndRefCounts cb_args merged_rhs - { cos_error = es_error, cos_var_heap = es_var_heap, cos_symbol_heap = es_symbol_heap } + (new_rhs, new_args, local_vars, {cos_error, cos_var_heap, cos_symbol_heap}) + = determineVariablesAndRefCounts cb_args merged_rhs + { cos_error = es_error, cos_var_heap = es_var_heap, cos_symbol_heap = es_symbol_heap, + cos_alias_dummy = alias_dummy } = (new_args, new_rhs, local_vars, all_calls, fun_defs, modules, { es & es_error = cos_error, es_var_heap = cos_var_heap, es_symbol_heap = cos_symbol_heap, es_symbol_table = es_symbol_table }) @@ -1142,6 +1145,7 @@ where { cos_var_heap :: !.VarHeap , cos_symbol_heap :: !.ExpressionHeap , cos_error :: !.ErrorAdmin + , cos_alias_dummy :: !PredefinedSymbol } determineVariablesAndRefCounts :: ![FreeVar] !Expression !*CollectState -> (!Expression , ![FreeVar], ![FreeVar], !*CollectState) @@ -1206,15 +1210,17 @@ where = (expr @ exprs, free_vars, cos) collectVariables (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) free_vars cos=:{cos_var_heap} # cos_var_heap = determine_aliases let_strict_binds cos_var_heap -// XXX: # cos_var_heap = foldSt (\bind cos_var_heap->clearCount bind cIsALocalVar cos_var_heap) let_strict_binds cos_var_heap - # cos_var_heap = determine_aliases let_lazy_binds cos_var_heap - (is_cyclic_s, let_strict_binds, cos_var_heap) = detect_cycles_and_remove_alias_binds let_strict_binds cos_var_heap - (is_cyclic_l, let_lazy_binds, cos_var_heap) = detect_cycles_and_remove_alias_binds let_lazy_binds cos_var_heap + cos_var_heap = determine_aliases let_lazy_binds cos_var_heap + (is_cyclic_s, let_strict_binds, cos) + = detect_cycles_and_handle_alias_binds True let_strict_binds + { cos & cos_var_heap = cos_var_heap } + (is_cyclic_l, let_lazy_binds, cos) + = detect_cycles_and_handle_alias_binds False let_lazy_binds cos | is_cyclic_s || is_cyclic_l = (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds }, free_vars, - { cos & cos_var_heap = cos_var_heap, cos_error = checkError "" "cyclic let definition" cos.cos_error}) + { cos & cos_error = checkError "" "cyclic let definition" cos.cos_error}) // | otherwise - # (let_expr, free_vars, cos) = collectVariables let_expr free_vars { cos & cos_var_heap = cos_var_heap } + # (let_expr, free_vars, cos) = collectVariables let_expr free_vars cos all_binds = mapAppend (\sb->(True, sb)) let_strict_binds [(False, lb) \\ lb<-let_lazy_binds] (collected_binds, free_vars, cos) = collect_variables_in_binds all_binds [] free_vars cos (let_strict_binds, let_lazy_binds) = split collected_binds @@ -1236,20 +1242,28 @@ where = var_heap - /* Remove all aliases from the list of 'let'-binds. Be careful with cycles! */ + /* Remove all aliases from the list of lazy 'let'-binds. Add a _dummyForStrictAlias + function call for the strict aliases. Be careful with cycles! */ - detect_cycles_and_remove_alias_binds [] var_heap - = (cContainsNoCycle, [], var_heap) - detect_cycles_and_remove_alias_binds [bind=:{bind_dst={fv_info_ptr}} : binds] var_heap - #! var_info = sreadPtr fv_info_ptr var_heap + detect_cycles_and_handle_alias_binds is_strict [] cos + = (cContainsNoCycle, [], cos) + detect_cycles_and_handle_alias_binds is_strict [bind=:{bind_dst={fv_info_ptr}} : binds] cos + #! var_info = sreadPtr fv_info_ptr cos.cos_var_heap = case var_info of VI_Alias {var_info_ptr} - | is_cyclic fv_info_ptr var_info_ptr var_heap - -> (cContainsACycle, binds, var_heap) - -> detect_cycles_and_remove_alias_binds binds var_heap + | is_cyclic fv_info_ptr var_info_ptr cos.cos_var_heap + -> (cContainsACycle, binds, cos) + | is_strict + # cos_var_heap = writePtr fv_info_ptr (VI_Count 0 cIsALocalVar) cos.cos_var_heap + (new_bind_src, cos) = add_dummy_id_for_strict_alias bind.bind_src + { cos & cos_var_heap = cos_var_heap } + (is_cyclic, binds, cos) + = detect_cycles_and_handle_alias_binds is_strict binds cos + -> (is_cyclic, [{ bind & bind_src = new_bind_src } : binds], cos) + -> detect_cycles_and_handle_alias_binds is_strict binds cos _ - # (is_cyclic, binds, var_heap) = detect_cycles_and_remove_alias_binds binds var_heap - -> (is_cyclic, [bind : binds], var_heap) + # (is_cyclic, binds, cos) = detect_cycles_and_handle_alias_binds is_strict binds cos + -> (is_cyclic, [bind : binds], cos) where is_cyclic orig_info_ptr info_ptr var_heap | orig_info_ptr == info_ptr @@ -1260,6 +1274,15 @@ where -> is_cyclic orig_info_ptr var_info_ptr var_heap _ -> False + + add_dummy_id_for_strict_alias bind_src cos=:{cos_symbol_heap, cos_alias_dummy} + # (new_app_info_ptr, cos_symbol_heap) = newPtr EI_Empty cos_symbol_heap + {pds_ident, pds_module, pds_def} = cos_alias_dummy + app_symb = { symb_name = pds_ident, + symb_kind = SK_Function {glob_module = pds_module, glob_object = pds_def}, + symb_arity = 1 } + = (App { app_symb = app_symb, app_args = [bind_src], app_info_ptr = new_app_info_ptr }, + { cos & cos_symbol_heap = cos_symbol_heap } ) /* Apply 'collectVariables' to the bound expressions (the 'bind_src' field of 'let'-bind) if the corresponding bound variable (the 'bind_dst' field) has been used. This can be determined |