Commit c1b39dd7 authored by cvs2snv's avatar cvs2snv

This commit was manufactured by cvs2svn to create tag 'suclmove'.

parent 33d2d7d1
backend.dll
BEGetVersion
BEInit
BEFree
BEArg
BEDeclareModules
BESpecialArrayFunctionSymbol
BEDictionarySelectFunSymbol
BEDictionaryUpdateFunSymbol
BEFunctionSymbol
BEConstructorSymbol
BEFieldSymbol
BETypeSymbol
BEDontCareDefinitionSymbol
BEBoolSymbol
BELiteralSymbol
BEPredefineConstructorSymbol
BEPredefineTypeSymbol
BEBasicSymbol
BEVarTypeNode
BETypeVars
BENoTypeVars
BENormalTypeNode
BEAnnotateTypeNode
BEAttributeTypeNode
BENoTypeArgs
BETypeArgs
BETypeAlt
BENormalNode
BEMatchNode
BETupleSelectNode
BEIfNode
BEGuardNode
BESwitchNode
BECaseNode
BEPushNode
BEDefaultNode
BESelectorNode
BEUpdateNode
BENodeIdNode
BENoArgs
BEArgs
BERuleAlt
BERuleAlts
BENoRuleAlts
BEDeclareNodeId
BENodeId
BEWildCardNodeId
BENodeDef
BENoNodeDefs
BENodeDefs
BEStrictNodeId
BENoStrictNodeIds
BEStrictNodeIds
BERule
BEDeclareRuleType
BEDefineRuleType
BEAdjustArrayFunction
BENoRules
BERules
BETypes
BENoTypes
BEFlatType
BEAlgebraicType
BERecordType
BEAbsType
BEConstructors
BENoConstructors
BEConstructor
BEDeclareField
BEField
BEFields
BENoFields
BEDeclareConstructor
BETypeVar
BEDeclareType
BEDeclareFunction
BECodeAlt
BEString
BEStrings
BENoStrings
BECodeParameter
BECodeParameters
BENoCodeParameters
BENodeIdListElem
BENodeIds
BENoNodeIds
BEAbcCodeBlock
BEAnyCodeBlock
BEDeclareIclModule
BEDeclareDclModule
BEDeclarePredefinedModule
BEDefineRules
BEGenerateCode
BEExportType
BESwapTypes
BEExportConstructor
BEExportField
BEExportFunction
BEDefineImportedObjsAndLibs
BESetMainDclModuleN
BEDeclareDynamicTypeSymbol
BEDynamicTempTypeSymbol
This diff is collapsed.
This diff is collapsed.
definition module backendconvert
from backend import BackEnd
import frontend
backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree !Int *VarHeap *BackEnd -> (!*VarHeap,!*BackEnd)
This diff is collapsed.
definition module backendinterface
import frontend
backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*File !*Files -> (!Bool,!*VarHeap, !*File, !*Files)
implementation module backendinterface
import StdEnv
import frontend
import backend
import backendpreprocess, backendsupport, backendconvert
import RWSDebug, Version
checkVersion :: VersionsCompatability *File -> (!Bool, !*File)
checkVersion VersionsAreCompatible errorFile
= (True, errorFile)
checkVersion VersionObservedIsTooNew errorFile
# errorFile
= fwrites "[Backend] the back end library is too new\n" errorFile
= (False, errorFile)
checkVersion VersionObservedIsTooOld errorFile
# errorFile
= fwrites "[Backend] the back end library is too old\n" errorFile
= (False, errorFile)
backEndInterface :: !{#Char} [{#Char}] !PredefinedSymbols !FrontEndSyntaxTree !Int !*VarHeap !*File !*Files -> (!Bool,!*VarHeap, !*File, !*Files)
backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_icl,fe_components} main_dcl_module_n var_heap errorFile files
# (observedCurrent, observedOldestDefinition, observedOldestImplementation)
= BEGetVersion
observedVersion =
{ versionCurrent
= observedCurrent
, versionOldestDefinition
= observedOldestDefinition
, versionOldestImplementation
= observedOldestImplementation
}
expectedVersion =
{ versionCurrent
= kBEVersionCurrent
, versionOldestDefinition
= kBEVersionOldestDefinition
, versionOldestImplementation
= kBEVersionOldestImplementation
}
# (compatible, errorFile)
= checkVersion (versionCompare expectedVersion observedVersion) errorFile
| not compatible
= (False, var_heap,errorFile, files)
# varHeap
= backEndPreprocess predef_symbols.[PD_DummyForStrictAliasFun].pds_ident functionIndices fe_icl var_heap
with
functionIndices
= flatten [[member \\ member <- group.group_members] \\ group <-: fe_components]
# backEndFiles
= 0
# (backEnd, backEndFiles)
= BEInit (length commandLineArgs) backEndFiles
# backEnd
= foldState BEArg commandLineArgs backEnd
# (var_heap,backEnd)
= backEndConvertModules predef_symbols syntaxTree main_dcl_module_n varHeap backEnd
# (success, backEnd)
= BEGenerateCode outputFileName backEnd
# backEndFiles
= BEFree backEnd backEndFiles
= (backEndFiles == 0 && success, var_heap,errorFile, files)
definition module backendpreprocess
import checksupport
// assign sequence numbers to all variables in the syntax tree
backEndPreprocess :: !Ident ![Index] !IclModule !*VarHeap -> *VarHeap
implementation module backendpreprocess
// assign sequence numbers to all variables in the syntax tree
import checksupport
import Heap
import backendsupport
import RWSDebug
backEndPreprocess :: !Ident ![Index] !IclModule !*VarHeap -> *VarHeap
backEndPreprocess aliasDummyId functionIndices iclModule varHeap
= preprocess aliasDummyId
[iclModule.icl_functions.[i] \\ i <- functionIndices] varHeap
class preprocess a :: !Ident a -> Preprocessor
:: Preprocessor
:== *PreprocessState -> *PreprocessState
:: PreprocessState
:== VarHeap
//1.3
instance preprocess {#a} | preprocess a & ArrayElem a where
//3.1
/*2.0
instance preprocess {#a} | preprocess a & Array {#} a where
0.2*/
preprocess aliasDummyId array
= foldStateA (preprocess aliasDummyId) array
instance preprocess [a] | preprocess a where
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
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_aliasDummyId :: !Ident}
toSequenceState aliasDummyId varHeap
:== {ss_sequenceNumber = 0, ss_varHeap = varHeap, ss_aliasDummyId = aliasDummyId}
fromSequenceState sequenceState
:== sequenceState.ss_varHeap
fromSequencerToPreprocessor aliasDummyId sequencer
:== toSequenceState aliasDummyId
o` sequencer
o` fromSequenceState
assignSequenceNumber varInfoPtr sequenceState
:== { sequenceState
& ss_varHeap = writePtr varInfoPtr (VI_SequenceNumber sequenceState.ss_sequenceNumber) sequenceState.ss_varHeap
, ss_sequenceNumber = sequenceState.ss_sequenceNumber + 1
}
instance sequence [a] | sequence a where
sequence list
= foldState sequence list
instance sequence (Optional a) | sequence a where
sequence (Yes x)
= sequence x
sequence No
= identity
// +++ this assigns sequence numbers per function, should be per alternative and moved to backendconvert
instance sequence FunctionBody where
sequence (BackendBody backEndBodies)
= sequence backEndBodies
sequence (TransformedBody transformedBody)
= sequence transformedBody
sequence body
= abort "preprocess (FunctionBody): unknown body" <<- body
// case test ...
instance sequence TransformedBody where
sequence body
= sequence body.tb_args
o` sequence body.tb_rhs
// ... case test
instance sequence BackendBody where
sequence body
= sequence body.bb_args
o` sequence body.bb_rhs
instance sequence FreeVar where
sequence freeVar
= sequence freeVar.fv_info_ptr
instance sequence Expression where
sequence (Let {let_strict_binds, let_lazy_binds, let_expr})
= sequence let_strict_binds
o` sequence let_lazy_binds
o` sequence let_expr
sequence (Conditional {if_then, if_else})
= sequence if_then
o` sequence if_else
sequence (App {app_args})
= sequence app_args
sequence (f @ arg)
= sequence f
o` sequence arg
sequence (Selection _ exp selections)
= sequence exp
o` sequence selections
sequence (AnyCodeExpr _ outParams _)
= foldState (\{bind_dst}->sequence bind_dst) outParams
sequence (Case caseExpr)
= sequence caseExpr
sequence _
= identity
instance sequence Case where
sequence {case_expr, case_guards, case_default}
= sequence case_expr
o` sequence case_guards
o` sequence case_default
instance sequence CasePatterns where
sequence (AlgebraicPatterns _ patterns)
= sequence patterns
sequence (BasicPatterns _ patterns)
= sequence patterns
instance sequence AlgebraicPattern where
sequence {ap_vars, ap_expr}
= sequence ap_vars
o` sequence ap_expr
instance sequence BasicPattern where
sequence {bp_expr}
= sequence bp_expr
instance sequence Selection where
sequence (RecordSelection _ _)
= identity
sequence (ArraySelection _ _ index)
= sequence index
sequence (DictionarySelection dictionaryVar dictionarySelections _ index)
= sequence index
// MW0 instance sequence (Bind Expression FreeVar) where
instance sequence LetBind where
// MW0 sequence {bind_src=App app , bind_dst}
sequence {lb_src=App app , lb_dst}
// MW0 = sequence` app bind_dst
= sequence` app lb_dst
where
// MW0 sequence` {app_symb, app_args} bind_dst sequenceState=:{ss_aliasDummyId}
sequence` {app_symb, app_args} lb_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
// MW0 ss_varHeap = writePtr bind_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap
ss_varHeap = writePtr lb_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap
-> { sequenceState & ss_varHeap = ss_varHeap }
_
// MW0 -> sequence bind_dst sequenceState
-> sequence lb_dst sequenceState
// MW0 = sequence bind_dst sequenceState
= sequence lb_dst sequenceState
sequence bind
// MW0 = sequence bind.bind_dst
= sequence bind.lb_dst
instance sequence FunctionPattern where
sequence (FP_Algebraic _ subpatterns optionalVar)
= sequence subpatterns
o` sequence optionalVar
sequence (FP_Variable freeVar)
= sequence freeVar
sequence (FP_Basic _ optionalVar)
= sequence optionalVar
sequence FP_Empty
= identity
instance sequence (Ptr VarInfo) where
sequence varInfoPtr
= assignSequenceNumber varInfoPtr
definition module backendsupport
//1.3
from StdArray import size, size_u
//3.1
/*2.0
from StdArray import size, usize
0.2*/
from StdFunc import `bind`
from StdInt import +, ==
import utilities
identity
:== \x -> x
// binding sugar
(==>) infix
(==>) f g
:== f `bind` g
// o` :== flip o
(o`) infixr
(o`) f g
:== \x -> g (f x)
(:-) infixl
(:-) a f
:== f a
foldState function list
:== foldState list
where
foldState []
= identity
foldState [hd:tl]
= function hd
o` foldState tl
foldStateA function array
:== foldStateA 0
where
arraySize
= size array
foldStateA index
| index == arraySize
= identity
// otherwise
= function array.[index]
o` foldStateA (index+1)
foldStateWithIndexA function array
:== foldStateWithIndexA 0
where
arraySize
= size array
foldStateWithIndexA index
| index == arraySize
= identity
// otherwise
= function index array.[index]
o` foldStateWithIndexA (index+1)
foldrA function result array
:== foldrA 0
where
arraySize
= size array
foldrA index
| index == arraySize
= result
// otherwise
= function array.[index] (foldrA (index+1))
implementation module backendsupport
import StdArray
from StdFunc import `bind`
from StdInt import +, ==
identity
:== \x -> x
// binding sugar
(==>) infix
(==>) f g
:== f `bind` g
// o` :== flip o
(o`) infixr
(o`) f g
:== \x -> g (f x)
(:-) infixl
(:-) a f
:== f a
foldState function list
:== foldState list
where
foldState []
= identity
foldState [hd:tl]
= function hd
o` foldState tl
foldStateA function array
:== foldStateA 0
where
arraySize
= size array
foldStateA index
| index == arraySize
= identity
// otherwise
= function array.[index]
o` foldStateA (index+1)
foldStateWithIndexA function array
:== foldStateWithIndexA 0
where
arraySize
= size array
foldStateWithIndexA index
| index == arraySize
= identity
// otherwise
= function index array.[index]
o` foldStateWithIndexA (index+1)
foldrA function result array
:== foldrA 0
where
arraySize
= size array
foldrA index
| index == arraySize
= result
// otherwise
= function array.[index] (foldrA (index+1))
This diff is collapsed.
definition module Heap
import StdEnv
:: Heap v = {heap::!.HeapN v}
:: HeapN v
:: Ptr v = {pointer::!.(PtrN v)};
:: PtrN v = Ptr !v !(HeapN v);
newHeap :: .Heap v
nilPtr :: Ptr v
isNilPtr :: !(Ptr v) -> Bool
newPtr :: !v !*(Heap v) -> (!.Ptr v,!.Heap v)
readPtr :: !(Ptr v) !u:(Heap v) -> (!v,!u:Heap v)
writePtr :: !(Ptr v) !v !*(Heap v) -> .Heap v
sreadPtr :: !(Ptr v) !(Heap v) -> v
ptrToInt :: !(Ptr w) -> Int
(<:=) infixl
(<:=) heap ptr_and_val :== writePtr ptr val heap
where
(ptr, val) = ptr_and_val
instance == (Ptr a)
implementation module Heap;
import StdOverloaded,StdMisc;
:: Heap v = {heap::!.(HeapN v)};
:: HeapN v = Heap !Int;
:: Ptr v = {pointer::!.(PtrN v)};
:: PtrN v = Ptr !v !(HeapN v);
newHeap :: .Heap v;
newHeap = {heap=Heap 0};
newPtr :: !v !*(Heap v) -> (!.Ptr v,!.Heap v);
newPtr v h = code {
build_r e_Heap_kPtr 2 0 0 0
update_a 0 1
pop_a 1
};
/*
nilPtr :: !v -> .Ptr v;
nilPtr v = code {
build _Nil 0 _hnf
push_a 1
update_a 1 2
update_a 0 1
pop_a 1
build_r e_Heap_kPtr 2 0 0 0
update_a 0 2
pop_a 2
};
*/
nilPtr :: Ptr v;
nilPtr =: make_nilPtr;
make_nilPtr :: Ptr v;
make_nilPtr = code {
build _Nil 0 _hnf
push_a 0
build_r e_Heap_kPtr 2 0 0 0
update_a 0 2
pop_a 2
};
isNilPtr :: !(Ptr v) -> Bool;
isNilPtr p = code {
repl_args 2 2
pop_a 1
eq_desc _Nil 0 0
pop_a 1
};
readPtr :: !(Ptr v) !u:(Heap v) -> (!v,!u:Heap v);
readPtr p h = code {
push_a_b 1
push_r_args_b 0 1 1 1 1
eqI
jmp_false read_heap_error
repl_r_args_a 2 0 1 1
.d 2 0
rtn
:read_heap_error
print "readPtr: Not a pointer of this heap"
halt
};
sreadPtr :: !(Ptr v) !(Heap v) -> v;
sreadPtr p h = code {
push_a_b 1
push_r_args_b 0 1 1 1 1
eqI
jmp_false sread_heap_error
repl_r_args_a 2 0 1 1
update_a 0 1
pop_a 1
.d 1 0
rtn
:sread_heap_error
print "sreadPtr: Not a pointer of this heap"
halt
};
writePtr :: !(Ptr v) !v !*(Heap v) -> .Heap v;
writePtr p v h
| isNilPtr p
= abort "writePtr: Nil pointer encountered\n";
= writePtr2 p v h;
writePtr2 :: !(Ptr v) !v !*(Heap v) -> .Heap v;
writePtr2 p v h = code {
push_a_b 2
push_r_args_b 0 1 1 1 1
eqI
jmp_false write_heap_error
push_a 1
fill1_r e_Heap_kPtr 2 0 1 010
.keep 0 2
pop_a 2
.d 1 0
rtn
:write_heap_error
print "writePtr: Not a pointer of this heap"