Newer
Older
implementation module backendconvert
import code from library "backend_library"
import StdEnv
import frontend
import backend
import backendsupport, backendpreprocess
import RWSDebug
// trace macro
(-*->) infixl
(-*->) value trace
:== value // ---> trace
:: BEMonad a :== St !*BackEnd !a
:: Backender :== *BackEnd -> *BackEnd
// foldr` :: (.a -> .(.b -> .b)) .b ![.a] -> .b // op e0 (op e1(...(op r e##)...)
foldr` op r l :== foldr l
where
foldr [] = r
foldr [a:x] = op a (foldr x)
flip` f x y
:== f y x
/* +++
:: *BackEndState = {bes_backEnd :: BackEnd, bes_varHeap :: *VarHeap}
appBackEnd f beState
# (result, bes_backEnd)
= f beState.bes_backEnd
= (result, {beState & bes_backEnd = bes_backEnd})
accVarHeap f beState
# (result, varHeap)
= f beState.bes_varHeap
= (result, {beState & bes_varHeap = varHeap})
*/
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
accVarHeap f beState :== f beState
beFunction0 f
:== appBackEnd f
beFunction1 f m1
:== m1 ==> \a1
-> appBackEnd (f a1)
beFunction2 f m1 m2
:== m1 ==> \a1
-> m2 ==> \a2
-> appBackEnd (f a1 a2)
beFunction3 f m1 m2 m3
:== m1 ==> \a1
-> m2 ==> \a2
-> m3 ==> \a3
-> appBackEnd (f a1 a2 a3)
beFunction4 f m1 m2 m3 m4
:== m1 ==> \a1
-> m2 ==> \a2
-> m3 ==> \a3
-> m4 ==> \a4
-> appBackEnd (f a1 a2 a3 a4)
beFunction5 f m1 m2 m3 m4 m5
:== m1 ==> \a1
-> m2 ==> \a2
-> m3 ==> \a3
-> m4 ==> \a4
-> m5 ==> \a5
-> appBackEnd (f a1 a2 a3 a4 a5)
beFunction6 f m1 m2 m3 m4 m5 m6
:== m1 ==> \a1
-> m2 ==> \a2
-> m3 ==> \a3
-> m4 ==> \a4
-> m5 ==> \a5
-> m6 ==> \a6
-> appBackEnd (f a1 a2 a3 a4 a5 a6)
beFunction7 f m1 m2 m3 m4 m5 m6 m7
:== m1 ==> \a1
-> m2 ==> \a2
-> m3 ==> \a3
-> m4 ==> \a4
-> m5 ==> \a5
-> m6 ==> \a6
-> m7 ==> \a7
-> appBackEnd (f a1 a2 a3 a4 a5 a6 a7)
changeArrayFunctionIndex selectIndex
:== selectIndex
beBoolSymbol value
:== beFunction0 (BEBoolSymbol value)
beLiteralSymbol type value
:== beFunction0 (BELiteralSymbol type value)
beFunctionSymbol functionIndex moduleIndex
:== beFunction0 (BEFunctionSymbol functionIndex moduleIndex)
beSpecialArrayFunctionSymbol arrayFunKind functionIndex moduleIndex
:== beFunction0 (BESpecialArrayFunctionSymbol arrayFunKind (changeArrayFunctionIndex functionIndex) moduleIndex)
beDictionarySelectFunSymbol
:== beFunction0 BEDictionarySelectFunSymbol
beDictionaryUpdateFunSymbol
:== beFunction0 BEDictionaryUpdateFunSymbol
beConstructorSymbol moduleIndex constructorIndex
:== beFunction0 (BEConstructorSymbol constructorIndex moduleIndex)
beFieldSymbol fieldIndex moduleIndex
:== beFunction0 (BEFieldSymbol fieldIndex moduleIndex)
beTypeSymbol typeIndex moduleIndex
:== beFunction0 (BETypeSymbol typeIndex moduleIndex)
beBasicSymbol typeSymbolIndex
:== beFunction0 (BEBasicSymbol typeSymbolIndex)
beDontCareDefinitionSymbol
:== beFunction0 BEDontCareDefinitionSymbol
beNoArgs
:== beFunction0 BENoArgs
beArgs
:== beFunction2 BEArgs
beNoTypeArgs
:== beFunction0 BENoTypeArgs
beTypeArgs
:== beFunction2 BETypeArgs
beNormalNode
:== beFunction2 BENormalNode
beIfNode
:== beFunction3 BEIfNode
beGuardNode
:== beFunction7 BEGuardNode
beSelectorNode selectorKind
:== beFunction2 (BESelectorNode selectorKind)
beUpdateNode
:== beFunction1 BEUpdateNode
beNormalTypeNode
:== beFunction2 BENormalTypeNode
beVarTypeNode name
:== beFunction0 (BEVarTypeNode name)
beRuleAlt lineNumber
:== beFunction5 (BERuleAlt lineNumber)
beNoRuleAlts
:== beFunction0 BENoRuleAlts
beRuleAlts
:== beFunction2 BERuleAlts
beTypeAlt
:== beFunction2 BETypeAlt
beRule index isCaf
:== beFunction2 (BERule index isCaf)
beNoRules
:== beFunction0 BENoRules
beRules
:== beFunction2 BERules
beNodeDef sequenceNumber
:== beFunction1 (BENodeDef sequenceNumber)
beNoNodeDefs
:== beFunction0 BENoNodeDefs
beNodeDefs
:== beFunction2 BENodeDefs
beStrictNodeId
:== beFunction1 BEStrictNodeId
beNoStrictNodeIds
:== beFunction0 BENoStrictNodeIds
beStrictNodeIds
:== beFunction2 BEStrictNodeIds
beNodeIdNode
:== beFunction2 BENodeIdNode
beNodeId sequenceNumber
:== beFunction0 (BENodeId sequenceNumber)
beWildCardNodeId
:== beFunction0 BEWildCardNodeId
beConstructor
:== beFunction1 BEConstructor
beNoConstructors
:== beFunction0 BENoConstructors
beConstructors
:== beFunction2 BEConstructors
beNoFields
:== beFunction0 BENoFields
beFields
:== beFunction2 BEFields
beField fieldIndex moduleIndex
:== beFunction1 (BEField fieldIndex moduleIndex)
beAnnotateTypeNode annotation
:== beFunction1 (BEAnnotateTypeNode annotation)
beAttributeTypeNode attribution
:== beFunction1 (BEAttributeTypeNode attribution)
beDeclareRuleType functionIndex moduleIndex name
:== beFunction0 (BEDeclareRuleType functionIndex moduleIndex name)
beDefineRuleType functionIndex moduleIndex
:== beFunction1 (BEDefineRuleType functionIndex moduleIndex)
beCodeAlt lineNumber
:== beFunction3 (BECodeAlt lineNumber)
beString string
:== beFunction0 (BEString string)
beStrings
:== beFunction2 BEStrings
beNoStrings
:== beFunction0 BENoStrings
beCodeParameter location
:== beFunction1 (BECodeParameter location)
beCodeParameters
:== beFunction2 BECodeParameters
beNoCodeParameters
:== beFunction0 BENoCodeParameters
beAbcCodeBlock inline
:== beFunction1 (BEAbcCodeBlock inline)
beAnyCodeBlock
:== beFunction3 BEAnyCodeBlock
beDeclareNodeId number lhsOrRhs name
:== beFunction0 (BEDeclareNodeId number lhsOrRhs name)
beAdjustArrayFunction backendId functionIndex moduleIndex
:== beFunction0 (BEAdjustArrayFunction backendId functionIndex moduleIndex)
beFlatType
:== beFunction2 BEFlatType
beNoTypeVars
:== beFunction0 BENoTypeVars
beTypeVars
:== beFunction2 BETypeVars
beTypeVar name
:== beFunction0 (BETypeVar name)
beExportType dclTypeIndex iclTypeIndex
:== beFunction0 (BEExportType dclTypeIndex iclTypeIndex)
beExportConstructor dclConstructorIndex iclConstructorIndex
:== beFunction0 (BEExportConstructor dclConstructorIndex iclConstructorIndex)
beExportField dclFieldIndex iclFieldIndex
:== beFunction0 (BEExportField dclFieldIndex iclFieldIndex)
beExportFunction dclIndexFunctionIndex iclFunctionIndex
:== beFunction0 (BEExportFunction dclIndexFunctionIndex iclFunctionIndex)
beTupleSelectNode arity index
:== beFunction1 (BETupleSelectNode arity index)
beMatchNode arity
:== beFunction2 (BEMatchNode arity)
beDefineImportedObjsAndLibs
:== beFunction2 BEDefineImportedObjsAndLibs
notYetImplementedExpr :: Expression
notYetImplementedExpr
= (BasicExpr (BVS "\"error in compiler (something was not implemented by lazy Ronny)\"") BT_Int)
backEndConvertModules :: PredefinedSymbols FrontEndSyntaxTree VarHeap *BackEnd -> *BackEnd
backEndConvertModules predefs {fe_icl = fe_icl =: {icl_name, icl_functions, icl_common, icl_imported_objects}, fe_components, fe_dcls, fe_arrayInstances, fe_dclIclConversions, fe_iclDclConversions, fe_globalFunctions} varHeap backEnd
// sanity check ...
// | cIclModIndex <> kIclModuleIndex || cPredefinedModuleIndex <> kPredefinedModuleIndex
// = undef <<- "backendconvert, backEndConvertModules: module index mismatch"
// ... sanity check
/*
# backEnd
= ruleDoesNotMatch 1 backEnd
with
ruleDoesNotMatch 0 backend
= backend
# backEnd
= abort "front end abort" backEnd
*/
= predefineSymbols fe_dcls.[cPredefinedModuleIndex] predefs backEnd
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
# currentDcl
= fe_dcls.[cIclModIndex]
typeConversions
= currentModuleTypeConversions icl_common.com_class_defs currentDcl.dcl_common.com_class_defs currentDcl.dcl_conversions
/*
# rstypes = reshuffleTypes (size icl_common.com_type_defs) typeConversions {type.td_name.id_name \\ type <-: currentDcl.dcl_common.com_type_defs}
types = {type.td_name.id_name \\ type <-: icl_common.com_type_defs}
# backEnd
= backEnd ->>
( "dcl conversions"
, currentDcl.dcl_conversions
, "dcl constructors"
, [constructor.cons_symb.id_name \\ constructor <-: currentDcl.dcl_common.com_cons_defs]
, "dcl selectors"
, [selector.sd_symb.id_name \\ selector <-: currentDcl.dcl_common.com_selector_defs]
, "dcl types"
, [type.td_name.id_name \\ type <-: currentDcl.dcl_common.com_type_defs]
, "icl selectors"
, [constructor.cons_symb.id_name \\ constructor <-: icl_common.com_cons_defs]
, "icl fields"
, [selector.sd_symb.id_name \\ selector <-: icl_common.com_selector_defs]
, "icl types"
, [type.td_name.id_name \\ type <-: icl_common.com_type_defs]
, "compare names"
, (rstypes, types)
)
*/
= declareCurrentDclModule fe_icl fe_dcls.[cIclModIndex] (backEnd -*-> "declareCurrentDclModule")
= declareOtherDclModules fe_dcls (backEnd -*-> "declareOtherDclModules")
= defineDclModule varHeap cIclModIndex fe_dcls.[cIclModIndex] (backEnd -*-> "defineDclModule(cIclMoIndex)")
= reshuffleTypes (size icl_common.com_type_defs) typeConversions (backEnd -*-> "reshuffleTypes")
= defineOtherDclModules fe_dcls varHeap (backEnd -*-> "defineOtherDclModules")
= BEDeclareIclModule icl_name.id_name (size icl_functions) (size icl_common.com_type_defs) (size icl_common.com_cons_defs) (size icl_common.com_selector_defs) (backEnd -*-> "BEDeclareIclModule")
# backEnd
= declareFunctionSymbols icl_functions (getConversions fe_iclDclConversions) functionIndices fe_globalFunctions (backEnd -*-> "declareFunctionSymbols")
with
getConversions :: (Optional {#Int}) -> {#Int}
getConversions No
= {}
getConversions (Yes conversions)
= conversions
= declare cIclModIndex varHeap icl_common (backEnd -*-> "declare (cIclModIndex)")
= declareArrayInstances fe_arrayInstances icl_functions (backEnd -*-> "declareArrayInstances")
= adjustArrayFunctions predefs fe_arrayInstances icl_functions fe_dcls varHeap (backEnd -*-> "adjustArrayFunctions")
= convertRules predefs.[PD_DummyForStrictAliasFun].pds_ident
[(index, icl_functions.[index]) \\ (_, index) <- functionIndices]
varHeap (backEnd -*-> "convertRules")
= BEDefineRules rules (backEnd -*-> "BEDefineRules")
= beDefineImportedObjsAndLibs
(convertStrings [imported.io_name \\ imported <- icl_imported_objects | not imported.io_is_library])
(convertStrings [imported.io_name \\ imported <- icl_imported_objects | imported.io_is_library])
(backEnd -*-> "beDefineImportedObjsAndLibs")
= markExports fe_dcls.[cIclModIndex] dcl_common.com_class_defs dcl_common.com_type_defs icl_common.com_class_defs icl_common.com_type_defs fe_dclIclConversions (backEnd -*-> "markExports")
with
dcl_common
= currentDcl.dcl_common
= (backEnd -*-> "backend done")
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
where
componentCount
= length functionIndices
functionIndices
= flatten [[(componentIndex, member) \\ member <- group.group_members] \\ group <-: fe_components & componentIndex <- [0..]]
declareOtherDclModules :: {#DclModule} -> Backender
declareOtherDclModules dcls
= foldStateWithIndexA declareOtherDclModule dcls
defineOtherDclModules :: {#DclModule} VarHeap -> Backender
defineOtherDclModules dcls varHeap
= foldStateWithIndexA (defineOtherDclModule varHeap) dcls
declareCurrentDclModule :: IclModule DclModule -> Backender
declareCurrentDclModule {icl_common} {dcl_name, dcl_functions, dcl_is_system, dcl_common}
= BEDeclareDclModule cIclModIndex dcl_name.id_name dcl_is_system (size dcl_functions) (size icl_common.com_type_defs) (size dcl_common.com_cons_defs) (size dcl_common.com_selector_defs)
declareOtherDclModule :: ModuleIndex DclModule -> Backender
declareOtherDclModule moduleIndex dclModule
| moduleIndex == cIclModIndex || moduleIndex == cPredefinedModuleIndex
= identity
// otherwise
= declareDclModule moduleIndex dclModule
declareDclModule :: ModuleIndex DclModule -> Backender
declareDclModule moduleIndex {dcl_name, dcl_common, dcl_functions, dcl_is_system}
= BEDeclareDclModule moduleIndex dcl_name.id_name dcl_is_system (size dcl_functions) (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs) (size dcl_common.com_selector_defs)
defineCurrentDclModule :: VarHeap IclModule DclModule {#Int} -> Backender
defineCurrentDclModule varHeap {icl_common} {dcl_name, dcl_common, dcl_functions, dcl_is_system, dcl_conversions} typeConversions
= declareCurrentDclModuleTypes icl_common.com_type_defs typeConversions varHeap
o` defineCurrentDclModuleTypes dcl_common.com_cons_defs dcl_common.com_selector_defs dcl_common.com_type_defs typeConversions varHeap
defineOtherDclModule :: VarHeap ModuleIndex DclModule -> Backender
defineOtherDclModule varHeap moduleIndex dclModule
| moduleIndex == cIclModIndex || moduleIndex == cPredefinedModuleIndex
= identity
// otherwise
= defineDclModule varHeap moduleIndex dclModule
defineDclModule :: VarHeap ModuleIndex DclModule -> Backender
defineDclModule varHeap moduleIndex {dcl_name, dcl_common, dcl_instances, dcl_functions, dcl_is_system}
o` declareFunTypes moduleIndex dcl_functions dcl_instances.ir_from varHeap
// move types from their dcl to icl positions
class swapTypes a :: Int Int *a -> *a
instance swapTypes BackEnd where
swapTypes i j be
= BESwapTypes i j be
instance swapTypes {{#Char}} where
swapTypes i j a
= swap i j a
swap i j a
#! iValue = a.[i]
#! jValue = a.[j]
= {a & [i] = jValue, [j] = iValue}
reshuffleTypes :: Int {#Int} *a -> *a | swapTypes a
reshuffleTypes nIclTypes dclIclConversions be
= thd3 (foldStateWithIndexA (swapType nDclTypes) dclIclConversions (idP nDclTypes, idP nIclTypes, be))
idP :: Int -> .{#Int}
idP n
= {i \\ i <- [0 .. n-1]}
swapType :: Int Int Int (*{#Int}, *{#Int}, *a) -> (*{#Int}, *{#Int}, *a) | swapTypes a
swapType nDclTypes dclIndex iclIndex state=:(p,p`,be)
#! frm
= p.[dclIndex]
#! to
= iclIndex
| frm == to
= state
// otherwise
#! frm` = dclIndex
#! to` = p`.[iclIndex]
= (swap frm` to` p, swap frm to p`, swapTypes frm to be)
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
:: 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
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
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
class declare a :: ModuleIndex !VarHeap a -> Backender
class declareWithIndex a :: Index ModuleIndex !VarHeap a -> Backender
instance declare {#a} | declareWithIndex a & ArrayElem a where
declare :: ModuleIndex VarHeap {#a} -> Backender | declareWithIndex a & ArrayElem a
//3.1
/*2.0
instance declare {#a} | declareWithIndex a & Array {#} a where
declare :: ModuleIndex VarHeap {#a} -> Backender | declareWithIndex a & Array {#} a
0.2*/
declare moduleIndex varHeap array
= foldStateWithIndexA (\i -> declareWithIndex i moduleIndex varHeap) array
declareFunctionSymbols :: {#FunDef} {#Int} [(Int, Int)] IndexRange *BackEnd -> *BackEnd
declareFunctionSymbols functions iclDclConversions functionIndices globalFunctions backEnd
= foldr` (declare iclDclConversions) backEnd [(functionIndex, componentIndex, functions.[functionIndex]) \\ (componentIndex, functionIndex) <- functionIndices]
where
declare :: {#Int} (Int, Int, FunDef) *BackEnd -> *BackEnd
declare iclDclConversions (functionIndex, componentIndex, function) backEnd
= BEDeclareFunction
(functionName function.fun_symb.id_name functionIndex iclDclConversions globalFunctions)
function.fun_arity functionIndex componentIndex backEnd
where
functionName :: {#Char} Int {#Int} IndexRange -> {#Char}
functionName name functionIndex iclDclConversions {ir_from, ir_to}
| functionIndex >= ir_to || functionIndex < ir_from
= (name +++ ";" +++ toString iclDclConversions.[functionIndex])
// otherwise
= name
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
// move to backendsupport
foldStateWithIndexRangeA function frm to array
:== foldStateWithIndexRangeA frm
where
foldStateWithIndexRangeA index
| index == to
= identity
// otherwise
= function index array.[index]
o` foldStateWithIndexRangeA (index+1)
declareArrayInstances :: IndexRange {#FunDef} -> Backender
declareArrayInstances {ir_from, ir_to} functions
= foldStateWithIndexRangeA declareArrayInstance ir_from ir_to functions
where
declareArrayInstance :: Index FunDef -> Backender
declareArrayInstance index {fun_symb={id_name}, fun_type=Yes type}
= beDeclareRuleType index cIclModIndex (id_name +++ ";" +++ toString index)
o` beDefineRuleType index cIclModIndex (convertTypeAlt index cIclModIndex type)
instance declare CommonDefs where
declare :: ModuleIndex VarHeap CommonDefs -> Backender
declare moduleIndex varHeap {com_cons_defs, com_type_defs, com_selector_defs, com_class_defs}
= declare moduleIndex varHeap com_type_defs
o` defineTypes moduleIndex com_cons_defs com_selector_defs com_type_defs varHeap
declareWithIndex :: Index ModuleIndex VarHeap (TypeDef a) -> Backender
declareWithIndex typeIndex moduleIndex _ {td_name}
= BEDeclareType typeIndex moduleIndex td_name.id_name
declareFunTypes :: ModuleIndex {#FunType} Int VarHeap -> Backender
declareFunTypes moduleIndex funTypes nrOfDclFunctions varHeap
= foldStateWithIndexA (declareFunType moduleIndex varHeap nrOfDclFunctions) funTypes
declareFunType :: ModuleIndex VarHeap Index Int FunType -> Backender
declareFunType moduleIndex varHeap nrOfDclFunctions functionIndex {ft_symb, ft_type_ptr}
= case (sreadPtr ft_type_ptr varHeap) of
VI_ExpandedType expandedType
-> beDeclareRuleType functionIndex moduleIndex (functionName ft_symb.id_name functionIndex nrOfDclFunctions)
o` beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType)
_
-> identity
where
functionName :: {#Char} Int Int -> {#Char}
functionName name functionIndex nrOfDclFunctions
| functionIndex < nrOfDclFunctions
= name
// otherwise
= name +++ ";" +++ toString functionIndex
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
currentModuleTypeConversions :: {#ClassDef} {#ClassDef} (Optional ConversionTable) -> {#Int}
currentModuleTypeConversions iclClasses dclClasses (Yes conversionTable)
// sanity check ...
| sort [dclClass.class_dictionary.ds_index \\ dclClass <-: dclClasses]
<> [size typeConversions .. size typeConversions + size dclClasses - 1]
= abort "backendconvert, currentModuleTypeConversions wrong index range for dcl dictionary types"
// ... sanity check
| nDclClasses == 0
= typeConversions
// otherwise
= {createArray (nDclTypes + nDclClasses) NoIndex
& [i] = typeConversion
\\ typeConversion <-: typeConversions & i <- [0..]}
:- foldStateWithIndexA (updateDictionaryTypeIndex classConversions) classConversions
where
typeConversions
= conversionTable.[cTypeDefs]
nDclTypes
= size typeConversions
classConversions
= conversionTable.[cClassDefs]
nDclClasses
= size classConversions
updateDictionaryTypeIndex :: {#Int} Int Int *{#Int} -> *{#Int}
updateDictionaryTypeIndex classConversions dclClassIndex iclClassIndex allTypeConversions
// sanity check ...
# (oldIndex, allTypeConversions)
= uselect allTypeConversions dclTypeIndex
| oldIndex <> NoIndex
= abort "backendconvert, updateDictionaryTypeIndex wrong index overwritten"
// ... sanity chechk
= {allTypeConversions & [dclTypeIndex] = iclTypeIndex}
where
dclTypeIndex
= dclClasses.[dclClassIndex].class_dictionary.ds_index
iclClassIndex
= classConversions.[dclClassIndex]
iclTypeIndex
= iclClasses.[iclClassIndex].class_dictionary.ds_index
currentModuleTypeConversions _ _ No
= {}
declareCurrentDclModuleTypes :: {#CheckedTypeDef} {#Int} VarHeap -> Backender
declareCurrentDclModuleTypes dclTypes typeConversions varHeap
= foldStateWithIndexA (declareConvertedType dclTypes varHeap) typeConversions
where
declareConvertedType :: {#CheckedTypeDef} VarHeap Index Index -> Backender
declareConvertedType dclTypes varHeap dclIndex iclIndex
= declareWithIndex iclIndex cIclModIndex varHeap dclTypes.[dclIndex]
defineCurrentDclModuleTypes :: {#ConsDef} {#SelectorDef} {#CheckedTypeDef} {#Int} VarHeap -> Backender
defineCurrentDclModuleTypes dclConstructors dclSelectors dclTypes typeConversions varHeap
= foldStateWithIndexA (defineConvertedType dclTypes varHeap) typeConversions
where
defineConvertedType :: {#CheckedTypeDef} VarHeap Index Index -> Backender
defineConvertedType dclTypes varHeap dclIndex iclIndex
= defineType cIclModIndex dclConstructors dclSelectors varHeap iclIndex dclTypes.[dclIndex]
defineTypes :: ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} VarHeap -> Backender
defineTypes moduleIndex constructors selectors types varHeap
= foldStateWithIndexA (defineType moduleIndex constructors selectors varHeap) types
convertTypeLhs :: ModuleIndex Index [ATypeVar] -> BEMonad BEFlatTypeP
convertTypeLhs moduleIndex typeIndex args
= beFlatType (beTypeSymbol typeIndex moduleIndex) (convertTypeVars args)
convertTypeVars :: [ATypeVar] -> BEMonad BETypeVarListP
convertTypeVars typeVars
= foldr` (beTypeVars o convertTypeVar) beNoTypeVars typeVars
convertTypeVar :: ATypeVar -> BEMonad BETypeVarP
convertTypeVar typeVar
= beTypeVar typeVar.atv_variable.tv_name.id_name
defineType :: ModuleIndex {#ConsDef} {#SelectorDef} VarHeap Index CheckedTypeDef *BackEnd -> *BackEnd
defineType moduleIndex constructors _ varHeap typeIndex {td_name, td_args, td_rhs=AlgType constructorSymbols} be
# (flatType, be)
= convertTypeLhs moduleIndex typeIndex td_args be
# (constructors, be)
= convertConstructors typeIndex td_name.id_name moduleIndex constructors constructorSymbols varHeap be
= BEAlgebraicType flatType constructors be
defineType moduleIndex constructors selectors varHeap typeIndex {td_args, td_rhs=RecordType {rt_constructor, rt_fields}} be
# (flatType, be)
= convertTypeLhs moduleIndex typeIndex td_args be
# (fields, be)
= convertSelectors moduleIndex selectors rt_fields varHeap be
# (constructorTypeNode, be)
= beNormalTypeNode
(beConstructorSymbol moduleIndex constructorIndex)
(convertSymbolTypeArgs constructorType)
be
= BERecordType moduleIndex flatType constructorTypeNode fields be
where
constructorIndex
= rt_constructor.ds_index
constructorDef
= constructors.[constructorIndex]
constructorType
= case (sreadPtr constructorDef.cons_type_ptr varHeap) of
VI_ExpandedType expandedType
-> expandedType
_
-> constructorDef.cons_type
defineType moduleIndex _ _ _ typeIndex {td_args, td_rhs=AbstractType _} be
= beAbsType (convertTypeLhs moduleIndex typeIndex td_args) be
convertConstructors :: Int {#Char} ModuleIndex {#ConsDef} [DefinedSymbol] VarHeap -> BEMonad BEConstructorListP
convertConstructors typeIndex typeName moduleIndex constructors symbols varHeap
= foldr` (beConstructors o convertConstructor typeIndex typeName moduleIndex constructors varHeap) beNoConstructors symbols
convertConstructor :: Int {#Char} ModuleIndex {#ConsDef} VarHeap DefinedSymbol -> BEMonad BEConstructorListP
convertConstructor typeIndex typeName moduleIndex constructorDefs varHeap {ds_index}
= BEDeclareConstructor ds_index moduleIndex constructorDef.cons_symb.id_name // +++ remove declare
o` beConstructor
(beNormalTypeNode
(beConstructorSymbol moduleIndex ds_index)
(convertSymbolTypeArgs constructorType))
where
constructorDef
= constructorDefs.[ds_index]
constructorType
= case (sreadPtr constructorDef.cons_type_ptr varHeap) of
VI_ExpandedType expandedType
-> expandedType // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, expandedType)
-> constructorDef.cons_type // ->> (typeName, typeIndex, constructorDef.cons_symb.id_name, ds_index, constructorDef.cons_type)
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
convertSelectors :: ModuleIndex {#SelectorDef} {#FieldSymbol} VarHeap -> BEMonad BEFieldListP
convertSelectors moduleIndex selectors symbols varHeap
= foldrA (beFields o convertSelector moduleIndex selectors varHeap) beNoFields symbols
convertSelector :: ModuleIndex {#SelectorDef} VarHeap FieldSymbol -> BEMonad BEFieldListP
convertSelector moduleIndex selectorDefs varHeap {fs_index}
= BEDeclareField fs_index moduleIndex selectorDef.sd_symb.id_name
o` beField fs_index moduleIndex (convertAnnotTypeNode (selectorType.st_result))
where
selectorDef
= selectorDefs.[fs_index]
selectorType
= case (sreadPtr selectorDef.sd_type_ptr varHeap) of
VI_ExpandedType expandedType
-> expandedType
_
-> selectorDef.sd_type
predefineSymbols :: DclModule PredefinedSymbols -> Backender
predefineSymbols {dcl_common} predefs
= BEDeclarePredefinedModule (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs)
o` foldState predefineType types
o` foldState predefineConstructor constructors
where
predefineType (index, arity, symbolKind)
// sanity check ...
| predefs.[index].pds_def == NoIndex
= abort "backendconvert, predefineSymbols predef is not a type"
// ... sanity check
= BEPredefineTypeSymbol arity predefs.[index].pds_def cPredefinedModuleIndex symbolKind
predefineConstructor (index, arity, symbolKind)
// sanity check ...
| predefs.[index].pds_def == NoIndex
= abort "backendconvert, predefineSymbols predef is not a constructor"
// ... sanity check
= BEPredefineConstructorSymbol arity predefs.[index].pds_def cPredefinedModuleIndex symbolKind
types :: [(Int, Int, BESymbKind)]
types
= [ (PD_ListType, 1, BEListType)
, (PD_LazyArrayType, 1, BEArrayType)
, (PD_StrictArrayType, 1, BEStrictArrayType)
, (PD_UnboxedArrayType, 1, BEUnboxedArrayType)
: [(index, index-PD_Arity2TupleType+2, BETupleType) \\ index <- [PD_Arity2TupleType..PD_Arity32TupleType]]
]
constructors :: [(Int, Int, BESymbKind)]
constructors
= [ (PD_NilSymbol, 0, BENilSymb)
, (PD_ConsSymbol, 2, BEConsSymb)
: [(index, index-PD_Arity2TupleSymbol+2, BETupleSymb) \\ index <- [PD_Arity2TupleSymbol..PD_Arity32TupleSymbol]]
]
:: AdjustStdArrayInfo =
{ asai_moduleIndex :: !Int
, asai_mapping :: !{#BEArrayFunKind}
, asai_funs :: !{#FunType}
, asai_varHeap :: !VarHeap
}
adjustArrayFunctions :: PredefinedSymbols IndexRange {#FunDef} {#DclModule} VarHeap -> Backender
adjustArrayFunctions predefs arrayInstancesRange functions dcls varHeap
= adjustStdArray arrayInfo predefs stdArray.dcl_common.com_instance_defs
o` adjustIclArrayInstances arrayInstancesRange arrayMemberMapping functions
where
arrayModuleIndex
= predefs.[PD_StdArray].pds_def
arrayClassIndex
= predefs.[PD_ArrayClass].pds_def
arrayClass
= stdArray.dcl_common.com_class_defs.[arrayClassIndex]
stdArray
= dcls.[arrayModuleIndex]
arrayMemberMapping
= getArrayMemberMapping predefs arrayClass.class_members
arrayInfo
= { asai_moduleIndex = arrayModuleIndex
, asai_mapping = arrayMemberMapping
, asai_funs = stdArray.dcl_functions
, asai_varHeap = varHeap
}
getArrayMemberMapping :: PredefinedSymbols {#DefinedSymbol} -> {#BEArrayFunKind}
getArrayMemberMapping predefs members
// sanity check ...
| size members <> length (memberIndexMapping predefs)
= abort "backendconvert, arrayMemberMapping: incorrect number of members"
// ... sanity check
= { createArray (size members) BENoArrayFun
& [i] = backEndFunKind member.ds_index (memberIndexMapping predefs) \\ member <-: members & i <- [0..]
}
where
memberIndexMapping :: PredefinedSymbols -> [(!Index, !BEArrayFunKind)]
memberIndexMapping predefs
= [(predefs.[predefIndex].pds_def, backEndArrayFunKind) \\ (predefIndex, backEndArrayFunKind) <- predefMapping]
where
predefMapping
= [ (PD_CreateArrayFun, BECreateArrayFun)
, (PD_ArraySelectFun, BEArraySelectFun)
, (PD_UnqArraySelectFun, BEUnqArraySelectFun)
, (PD_ArrayUpdateFun, BEArrayUpdateFun)
, (PD_ArrayReplaceFun, BEArrayReplaceFun)
, (PD_ArraySizeFun, BEArraySizeFun)
, (PD_UnqArraySizeFun, BEUnqArraySizeFun)
, (PD__CreateArrayFun, BE_CreateArrayFun)
]
backEndFunKind :: Index [(!Index, !BEArrayFunKind)] -> BEArrayFunKind
backEndFunKind memberIndex predefMapping
= hd [back \\ (predefMemberIndex, back) <- predefMapping | predefMemberIndex == memberIndex]
adjustStdArray :: AdjustStdArrayInfo PredefinedSymbols {#ClassInstance} -> Backender
adjustStdArray arrayInfo predefs instances
| arrayModuleIndex == NoIndex
= identity
// otherwise
= foldStateA (adjustStdArrayInstance arrayClassIndex arrayInfo) instances
where
adjustStdArrayInstance :: Index AdjustStdArrayInfo ClassInstance -> Backender
adjustStdArrayInstance arrayClassIndex arrayInfo=:{asai_moduleIndex} instance`=:{ins_class}
| ins_class.glob_object.ds_index == arrayClassIndex && ins_class.glob_module == asai_moduleIndex
= adjustArrayClassInstance arrayInfo instance`
// otherwise
= identity
where
adjustArrayClassInstance :: AdjustStdArrayInfo ClassInstance -> Backender
adjustArrayClassInstance arrayInfo {ins_members}
= foldStateWithIndexA (adjustMember arrayInfo) ins_members
where
adjustMember :: AdjustStdArrayInfo Int DefinedSymbol -> Backender
adjustMember {asai_moduleIndex, asai_mapping, asai_funs, asai_varHeap} offset {ds_index}
= case (sreadPtr asai_funs.[ds_index].ft_type_ptr asai_varHeap) of
VI_ExpandedType _
-> beAdjustArrayFunction asai_mapping.[offset] ds_index asai_moduleIndex
_
-> identity
adjustIclArrayInstances :: IndexRange {#BEArrayFunKind} {#FunDef} -> Backender
adjustIclArrayInstances {ir_from, ir_to} mapping instances
= foldStateWithIndexRangeA (adjustIclArrayInstance mapping) ir_from ir_to instances
where
adjustIclArrayInstance :: {#BEArrayFunKind} Index FunDef -> Backender
// for array functions fun_index is not the index in the FunDef array,
// but its member index in the Array class
adjustIclArrayInstance mapping index {fun_index}
= beAdjustArrayFunction mapping.[fun_index] index cIclModIndex
convertRules :: Ident [(Int, FunDef)] VarHeap *BackEnd -> (BEImpRuleP, *BackEnd)
convertRules aliasDummyId rules varHeap be
# (null, be)
= BENoRules be
= convert rules varHeap null be
// = foldr` (beRules o flip` convertRule varHeap) beNoRules rules
where
convert :: [(Int, FunDef)] VarHeap BEImpRuleP *BackEnd -> (BEImpRuleP, *BackEnd)
convert [] _ rulesP be
= (rulesP, be)
convert [h:t] varHeap rulesP be
# (ruleP, be)
= convertRule aliasDummyId h varHeap be
# (rulesP, be)
= BERules ruleP rulesP be
= convert t varHeap rulesP be
convertRule :: Ident (Int,FunDef) VarHeap -> BEMonad BEImpRuleP
convertRule aliasDummyId (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) aliasDummyId body varHeap)
where
cafness :: FunKind -> Int
cafness (FK_Function _)
= BEIsNotACaf
cafness FK_Macro
= BEIsNotACaf
cafness FK_Caf
= BEIsACaf
cafness funKind
= BEIsNotACaf <<- ("backendconvert, cafness: unknown fun kind", funKind)
positionToLineNumber :: Position -> Int
positionToLineNumber (FunPos _ lineNumber _)
= lineNumber
positionToLineNumber (LinePos _ lineNumber)
= lineNumber
positionToLineNumber _
= -1
convertFunctionBody :: Int Int Ident FunctionBody VarHeap -> BEMonad BERuleAltP
convertFunctionBody functionIndex lineNumber aliasDummyId (BackendBody bodies) varHeap
= convertBackendBodies functionIndex lineNumber aliasDummyId bodies varHeap
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
convertTypeAlt :: Int ModuleIndex SymbolType -> BEMonad BETypeAltP
convertTypeAlt functionIndex moduleIndex symbol=:{st_result}
= beTypeAlt (beNormalTypeNode (beFunctionSymbol functionIndex moduleIndex) (convertSymbolTypeArgs symbol)) (convertAnnotTypeNode st_result)
convertSymbolTypeArgs :: SymbolType -> BEMonad BETypeArgP
convertSymbolTypeArgs {st_args}
= convertTypeArgs st_args
convertBasicTypeKind :: BasicType -> BESymbKind
convertBasicTypeKind BT_Int
= BEIntType
convertBasicTypeKind BT_Char
= BECharType
convertBasicTypeKind BT_Real
= BERealType
convertBasicTypeKind BT_Bool
= BEBoolType
convertBasicTypeKind BT_File
= BEFileType
convertBasicTypeKind BT_World
= BEWorldType
convertBasicTypeKind BT_Dynamic
= BEDynamicType
convertBasicTypeKind (BT_String _)
= undef <<- "convertBasicTypeKind (BT_String _) shouldn't occur"
convertAnnotation :: Annotation -> BEAnnotation
convertAnnotation AN_None
= BENoAnnot
convertAnnotation AN_Strict
= BEStrictAnnot
convertAttribution :: TypeAttribute -> BEAttribution
convertAttribution TA_Unique
= BEUniqueAttr
convertAttribution _ // +++ uni vars, etc.
= BENoUniAttr
convertAnnotTypeNode :: AType -> BEMonad BETypeNodeP
convertAnnotTypeNode {at_type, at_annotation, at_attribute}
= convertTypeNode at_type
:- beAnnotateTypeNode (convertAnnotation at_annotation)
:- beAttributeTypeNode (convertAttribution (at_attribute))
convertTypeNode :: Type -> BEMonad BETypeNodeP
convertTypeNode (TB (BT_String type))
= convertTypeNode type
convertTypeNode (TB basicType)
= beNormalTypeNode (beBasicSymbol (convertBasicTypeKind basicType)) beNoTypeArgs
convertTypeNode (TA typeSymbolIdent typeArgs)
= beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertTypeArgs typeArgs)
convertTypeNode (TV {tv_name})
= beVarTypeNode tv_name.id_name
convertTypeNode (TempQV n)
= beVarTypeNode ("_tqv" +++ toString n)
convertTypeNode (TempV n)
= beVarTypeNode ("_tv" +++ toString n)
convertTypeNode (a --> b)
= beNormalTypeNode (beBasicSymbol BEFunType) (convertTypeArgs [a, b])
convertTypeNode (a :@: b)
= beNormalTypeNode (beBasicSymbol BEApplySymb) (convertTypeArgs [{at_attribute=TA_Multi, at_annotation=AN_None, at_type = consVariableToType a} : b])
convertTypeNode TE
= beNormalTypeNode beDontCareDefinitionSymbol beNoTypeArgs
convertTypeNode typeNode
= undef <<- ("backendconvert, convertTypeNode: unknown type node", typeNode)
consVariableToType :: ConsVariable -> Type
consVariableToType (CV typeVar)
= TV typeVar
consVariableToType (TempCV varId)
= TempV varId
consVariableToType (TempQCV varId)
= TempQV varId
convertTypeArgs :: [AType] -> BEMonad BETypeArgP
convertTypeArgs args
= foldr` (beTypeArgs o convertAnnotTypeNode) beNoTypeArgs args
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
convertBackendBody :: Int Int Ident BackendBody VarHeap -> BEMonad BERuleAltP
convertBackendBody functionIndex lineNumber aliasDummyId body=:{bb_args, bb_rhs=ABCCodeExpr instructions inline} varHeap
-> declareVars body (aliasDummyId, varHeap)
o` beCodeAlt
lineNumber
(convertLhsNodeDefs bb_args noNodeDefs varHeap)
(convertBackendLhs functionIndex bb_args varHeap)
(beAbcCodeBlock inline (convertStrings instructions))