Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-compiler-and-rts
compiler
Commits
bf77a4f7
Commit
bf77a4f7
authored
Jul 12, 2001
by
Ronny Wichers Schreur
🏢
Browse files
uniqueness attributes in backend
parent
7c55c5cf
Changes
15
Hide whitespace changes
Inline
Side-by-side
backend/Clean System Files/backend_library
View file @
bf77a4f7
...
...
@@ -23,6 +23,12 @@ BENoTypeVars
BENormalTypeNode
BEAnnotateTypeNode
BEAttributeTypeNode
BEAttributeKind
BENoAttributeKinds
BEAttributeKinds
BEUniVarEquation
BENoUniVarEquations
BEUniVarEquationsList
BENoTypeArgs
BETypeArgs
BETypeAlt
...
...
backend/backend.dcl
View file @
bf77a4f7
...
...
@@ -29,6 +29,8 @@ from StdString import String;
::
BEStringListP
;
::
BENodeIdListP
;
::
BENodeIdRefCountListP
;
::
BEUniVarEquations
;
::
BEAttributeKindList
;
::
BEAnnotation
:==
Int
;
::
BEAttribution
:==
Int
;
::
BESymbKind
:==
Int
;
...
...
@@ -83,12 +85,24 @@ BEAnnotateTypeNode :: !BEAnnotation !BETypeNodeP !BackEnd -> (!BETypeNodeP,!Back
// BETypeNodeP BEAnnotateTypeNode (BEAnnotation annotation,BETypeNodeP typeNode);
BEAttributeTypeNode
::
!
BEAttribution
!
BETypeNodeP
!
BackEnd
->
(!
BETypeNodeP
,!
BackEnd
);
// BETypeNodeP BEAttributeTypeNode (BEAttribution attribution,BETypeNodeP typeNode);
BEAttributeKind
::
!
BEAttribution
!
BackEnd
->
(!
BEAttributeKindList
,!
BackEnd
);
// BEAttributeKindList BEAttributeKind (BEAttribution attributeKind);
BENoAttributeKinds
::
!
BackEnd
->
(!
BEAttributeKindList
,!
BackEnd
);
// BEAttributeKindList BENoAttributeKinds ();
BEAttributeKinds
::
!
BEAttributeKindList
!
BEAttributeKindList
!
BackEnd
->
(!
BEAttributeKindList
,!
BackEnd
);
// BEAttributeKindList BEAttributeKinds (BEAttributeKindList elem,BEAttributeKindList list);
BEUniVarEquation
::
!
BEAttribution
!
BEAttributeKindList
!
BackEnd
->
(!
BEUniVarEquations
,!
BackEnd
);
// BEUniVarEquations BEUniVarEquation (BEAttribution demanded,BEAttributeKindList offered);
BENoUniVarEquations
::
!
BackEnd
->
(!
BEUniVarEquations
,!
BackEnd
);
// BEUniVarEquations BENoUniVarEquations ();
BEUniVarEquationsList
::
!
BEUniVarEquations
!
BEUniVarEquations
!
BackEnd
->
(!
BEUniVarEquations
,!
BackEnd
);
// BEUniVarEquations BEUniVarEquationsList (BEUniVarEquations elem,BEUniVarEquations list);
BENoTypeArgs
::
!
BackEnd
->
(!
BETypeArgP
,!
BackEnd
);
// BETypeArgP BENoTypeArgs ();
BETypeArgs
::
!
BETypeNodeP
!
BETypeArgP
!
BackEnd
->
(!
BETypeArgP
,!
BackEnd
);
// BETypeArgP BETypeArgs (BETypeNodeP node,BETypeArgP nextArgs);
BETypeAlt
::
!
BETypeNodeP
!
BETypeNodeP
!
BackEnd
->
(!
BETypeAltP
,!
BackEnd
);
// BETypeAltP BETypeAlt (BETypeNodeP lhs,BETypeNodeP rhs);
BETypeAlt
::
!
BETypeNodeP
!
BETypeNodeP
!
BEUniVarEquations
!
BackEnd
->
(!
BETypeAltP
,!
BackEnd
);
// BETypeAltP BETypeAlt (BETypeNodeP lhs,BETypeNodeP rhs
,BEUniVarEquations attributeEquations
);
BENormalNode
::
!
BESymbolP
!
BEArgP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
// BENodeP BENormalNode (BESymbolP symbol,BEArgP args);
BEMatchNode
::
!
Int
!
BESymbolP
!
BENodeP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
...
...
@@ -247,9 +261,9 @@ BEDeclareDynamicTypeSymbol :: !Int !Int !BackEnd -> BackEnd;
// void BEDeclareDynamicTypeSymbol (int typeIndex,int moduleIndex);
BEDynamicTempTypeSymbol
::
!
BackEnd
->
(!
BESymbolP
,!
BackEnd
);
// BESymbolP BEDynamicTempTypeSymbol ();
kBEVersionCurrent
:==
0x0200020
9
;
kBEVersionOldestDefinition
:==
0x0200020
4
;
kBEVersionOldestImplementation
:==
0x0200020
9
;
kBEVersionCurrent
:==
0x020002
1
0
;
kBEVersionOldestDefinition
:==
0x020002
1
0
;
kBEVersionOldestImplementation
:==
0x020002
1
0
;
kBEDebug
:==
1
;
kPredefinedModuleIndex
:==
1
;
BENoAnnot
:==
0
;
...
...
backend/backend.icl
View file @
bf77a4f7
...
...
@@ -29,6 +29,8 @@ from StdString import String;
::
BEStringListP
:==
CPtr
;
::
BENodeIdListP
:==
CPtr
;
::
BENodeIdRefCountListP
:==
CPtr
;
::
BEUniVarEquations
:==
CPtr
;
::
BEAttributeKindList
:==
CPtr
;
::
BEAnnotation
:==
Int
;
::
BEAttribution
:==
Int
;
::
BESymbKind
:==
Int
;
...
...
@@ -180,6 +182,42 @@ BEAttributeTypeNode a0 a1 a2 = code {
}
;
// BETypeNodeP BEAttributeTypeNode (BEAttribution attribution,BETypeNodeP typeNode);
BEAttributeKind
::
!
BEAttribution
!
BackEnd
->
(!
BEAttributeKindList
,!
BackEnd
);
BEAttributeKind
a0
a1
=
code {
ccall
BEAttributeKind
"I:I:I"
}
;
// BEAttributeKindList BEAttributeKind (BEAttribution attributeKind);
BENoAttributeKinds
::
!
BackEnd
->
(!
BEAttributeKindList
,!
BackEnd
);
BENoAttributeKinds
a0
=
code {
ccall
BENoAttributeKinds
":I:I"
}
;
// BEAttributeKindList BENoAttributeKinds ();
BEAttributeKinds
::
!
BEAttributeKindList
!
BEAttributeKindList
!
BackEnd
->
(!
BEAttributeKindList
,!
BackEnd
);
BEAttributeKinds
a0
a1
a2
=
code {
ccall
BEAttributeKinds
"II:I:I"
}
;
// BEAttributeKindList BEAttributeKinds (BEAttributeKindList elem,BEAttributeKindList list);
BEUniVarEquation
::
!
BEAttribution
!
BEAttributeKindList
!
BackEnd
->
(!
BEUniVarEquations
,!
BackEnd
);
BEUniVarEquation
a0
a1
a2
=
code {
ccall
BEUniVarEquation
"II:I:I"
}
;
// BEUniVarEquations BEUniVarEquation (BEAttribution demanded,BEAttributeKindList offered);
BENoUniVarEquations
::
!
BackEnd
->
(!
BEUniVarEquations
,!
BackEnd
);
BENoUniVarEquations
a0
=
code {
ccall
BENoUniVarEquations
":I:I"
}
;
// BEUniVarEquations BENoUniVarEquations ();
BEUniVarEquationsList
::
!
BEUniVarEquations
!
BEUniVarEquations
!
BackEnd
->
(!
BEUniVarEquations
,!
BackEnd
);
BEUniVarEquationsList
a0
a1
a2
=
code {
ccall
BEUniVarEquationsList
"II:I:I"
}
;
// BEUniVarEquations BEUniVarEquationsList (BEUniVarEquations elem,BEUniVarEquations list);
BENoTypeArgs
::
!
BackEnd
->
(!
BETypeArgP
,!
BackEnd
);
BENoTypeArgs
a0
=
code {
ccall
BENoTypeArgs
":I:I"
...
...
@@ -192,11 +230,11 @@ BETypeArgs a0 a1 a2 = code {
}
;
// BETypeArgP BETypeArgs (BETypeNodeP node,BETypeArgP nextArgs);
BETypeAlt
::
!
BETypeNodeP
!
BETypeNodeP
!
BackEnd
->
(!
BETypeAltP
,!
BackEnd
);
BETypeAlt
a0
a1
a2
=
code {
ccall
BETypeAlt
"II:I:I"
BETypeAlt
::
!
BETypeNodeP
!
BETypeNodeP
!
BEUniVarEquations
!
BackEnd
->
(!
BETypeAltP
,!
BackEnd
);
BETypeAlt
a0
a1
a2
a3
=
code {
ccall
BETypeAlt
"II
I
:I:I"
}
;
// BETypeAltP BETypeAlt (BETypeNodeP lhs,BETypeNodeP rhs);
// BETypeAltP BETypeAlt (BETypeNodeP lhs,BETypeNodeP rhs
,BEUniVarEquations attributeEquations
);
BENormalNode
::
!
BESymbolP
!
BEArgP
!
BackEnd
->
(!
BENodeP
,!
BackEnd
);
BENormalNode
a0
a1
a2
=
code {
...
...
@@ -671,9 +709,9 @@ BEDynamicTempTypeSymbol a0 = code {
ccall
BEDynamicTempTypeSymbol
":I:I"
}
;
// BESymbolP BEDynamicTempTypeSymbol ();
kBEVersionCurrent
:==
0x0200020
9
;
kBEVersionOldestDefinition
:==
0x0200020
4
;
kBEVersionOldestImplementation
:==
0x0200020
9
;
kBEVersionCurrent
:==
0x020002
1
0
;
kBEVersionOldestDefinition
:==
0x020002
1
0
;
kBEVersionOldestImplementation
:==
0x020002
1
0
;
kBEDebug
:==
1
;
kPredefinedModuleIndex
:==
1
;
BENoAnnot
:==
0
;
...
...
backend/backendconvert.dcl
View file @
bf77a4f7
...
...
@@ -3,4 +3,4 @@ definition module backendconvert
from
backend
import
BackEnd
import
frontend
backEndConvertModules
::
PredefinedSymbols
FrontEndSyntaxTree
!
Int
*
VarHeap
*
BackEnd
->
(!*
VarHeap
,!*
BackEnd
)
backEndConvertModules
::
PredefinedSymbols
FrontEndSyntaxTree
!
Int
*
VarHeap
*
AttrVarHeap
*
BackEnd
->
(!*
VarHeap
,
*
AttrVarHeap
,
!*
BackEnd
)
backend/backendconvert.icl
View file @
bf77a4f7
...
...
@@ -37,7 +37,7 @@ BackEndBody x :== BackendBody x
::
BackEnder
:==
*
BackEndState
->
*
BackEndState
//
::
*
BackEndState
=
{
bes_backEnd
::
!
BackEnd
,
bes_varHeap
::
!*
VarHeap
}
::
*
BackEndState
=
{
bes_backEnd
::
!
BackEnd
,
bes_varHeap
::
!*
VarHeap
,
bes_attrHeap
::
!*
AttrVarHeap
,
bes_attr_number
::
!
Int
}
appBackEnd
f
beState
:==
{
beState
&
bes_backEnd
=
bes_backEnd
}
...
...
@@ -57,6 +57,13 @@ accVarHeap f beState
where
(
result
,
varHeap
)
=
f
beState
.
bes_varHeap
accAttrHeap
f
beState
:==
(
result
,
{
beState
&
bes_attrHeap
=
attrHeap
})
where
(
result
,
attrHeap
)
=
f
beState
.
bes_attrHeap
read_from_var_heap
::
VarInfoPtr
BackEndState
->
(
VarInfo
,
BackEndState
)
read_from_var_heap
ptr
beState
=
(
result
,
{
beState
&
bes_varHeap
=
varHeap
})
where
...
...
@@ -64,6 +71,14 @@ where
write_to_var_heap
ptr
v
beState
=
{
beState
&
bes_varHeap
=
writePtr
ptr
v
beState
.
bes_varHeap
}
read_from_attr_heap
ptr
beState
=
(
result
,
{
beState
&
bes_attrHeap
=
attrHeap
})
where
(
result
,
attrHeap
)
=
readPtr
ptr
beState
.
bes_attrHeap
write_to_attr_heap
ptr
v
beState
=
{
beState
&
bes_attrHeap
=
writePtr
ptr
v
beState
.
bes_attrHeap
}
/*
read_from_var_heap ptr heap be
= (sreadPtr ptr heap,be)
...
...
@@ -219,7 +234,7 @@ beNoRuleAlts
beRuleAlts
:==
beFunction2
BERuleAlts
beTypeAlt
:==
beFunction
2
BETypeAlt
:==
beFunction
3
BETypeAlt
beRule
index
isCaf
:==
beFunction2
(
BERule
index
isCaf
)
beNoRules
...
...
@@ -258,8 +273,8 @@ beField fieldIndex moduleIndex
:==
beFunction1
(
BEField
fieldIndex
moduleIndex
)
beAnnotateTypeNode
annotation
:==
beFunction1
(
BEAnnotateTypeNode
annotation
)
beAttributeTypeNode
attribution
:==
beFunction
1
(
BEAttributeTypeNode
attribution
)
beAttributeTypeNode
:==
beFunction
2
BEAttributeTypeNode
beDeclareRuleType
functionIndex
moduleIndex
name
:==
beApFunction0
(
BEDeclareRuleType
functionIndex
moduleIndex
name
)
beDefineRuleType
functionIndex
moduleIndex
...
...
@@ -324,6 +339,19 @@ beNodeIds
:==
beFunction2
BENodeIds
beNodeIdListElem
:==
beFunction1
BENodeIdListElem
beAttributeKind
:==
beFunction1
BEAttributeKind
beNoAttributeKinds
:==
beFunction0
BENoAttributeKinds
beAttributeKinds
:==
beFunction2
BEAttributeKinds
beUniVarEquation
:==
beFunction2
BEUniVarEquation
beNoUniVarEquations
:==
beFunction0
BENoUniVarEquations
beUniVarEquationsList
:==
beFunction2
BEUniVarEquationsList
// temporary hack
beDynamicTempTypeSymbol
:==
beFunction0
BEDynamicTempTypeSymbol
...
...
@@ -332,17 +360,20 @@ notYetImplementedExpr :: Expression
notYetImplementedExpr
=
(
BasicExpr
(
BVS
"
\"
error in compiler (something was not implemented by lazy Ronny)
\"
"
)
BT_Int
)
backEndConvertModules
::
PredefinedSymbols
FrontEndSyntaxTree
!
Int
*
VarHeap
*
BackEnd
->
(!*
VarHeap
,!*
BackEnd
)
backEndConvertModules
::
PredefinedSymbols
FrontEndSyntaxTree
!
Int
*
VarHeap
*
AttrVarHeap
*
BackEnd
->
(!*
VarHeap
,
*
AttrVarHeap
,
!*
BackEnd
)
/*
backEndConvertModules p s main_dcl_module_n v be
= (newHeap,backEndConvertModulesH p s v be)
*/
backEndConvertModules
p
s
main_dcl_module_n
var_heap
be
#
{
bes_varHeap
,
bes_backEnd
}
=
backEndConvertModulesH
p
s
main_dcl_module_n
{
bes_varHeap
=
var_heap
,
bes_
backEnd
=
be
}
=
(
bes_varHeap
,
bes_backEnd
)
backEndConvertModules
p
s
main_dcl_module_n
var_heap
attr_var_heap
be
#
{
bes_varHeap
,
bes_
attrHeap
,
bes_
backEnd
}
=
backEndConvertModulesH
p
s
main_dcl_module_n
{
bes_varHeap
=
var_heap
,
bes_
attrHeap
=
attr_var_heap
,
bes_backEnd
=
be
,
bes_attr_number
=
0
}
=
(
bes_varHeap
,
bes_
attrHeap
,
bes_
backEnd
)
backEndConvertModulesH
::
PredefinedSymbols
FrontEndSyntaxTree
!
Int
*
BackEndState
->
*
BackEndState
backEndConvertModulesH
predefs
{
fe_icl
=
fe_icl
=:
{
icl_name
,
icl_functions
,
icl_common
,
icl_imported_objects
,
icl_used_module_numbers
},
fe_components
,
fe_dcls
,
fe_arrayInstances
,
fe_dclIclConversions
,
fe_iclDclConversions
,
fe_globalFunctions
}
main_dcl_module_n
backEnd
backEndConvertModulesH
predefs
{
fe_icl
=
fe_icl
=:
{
icl_name
,
icl_functions
,
icl_common
,
icl_imported_objects
,
icl_used_module_numbers
},
fe_components
,
fe_dcls
,
fe_arrayInstances
,
fe_dclIclConversions
,
fe_iclDclConversions
,
fe_globalFunctions
}
main_dcl_module_n
backEnd
// sanity check ...
// | cIclModIndex <> kIclModuleIndex || cPredefinedModuleIndex <> kPredefinedModuleIndex
// = undef <<- "backendconvert, backEndConvertModules: module index mismatch"
...
...
@@ -437,8 +468,6 @@ backEndConvertModulesH predefs {fe_icl = fe_icl =: {icl_name, icl_functions, icl
#!
backEnd
=
removeExpandedTypesFromDclModules
fe_dcls
icl_used_module_numbers
backEnd
=
(
backEnd
-*->
"backend done"
)
where
componentCount
=
length
functionIndices
functionIndices
=
flatten
[[(
componentIndex
,
member
)
\\
member
<-
group
.
group_members
]
\\
group
<-:
fe_components
&
componentIndex
<-
[
0
..]]
...
...
@@ -484,8 +513,8 @@ declareDclModule moduleIndex {dcl_name, dcl_common, dcl_functions, dcl_module_ki
/*
defineCurrentDclModule :: IclModule DclModule {#Int} -> BackEnder
defineCurrentDclModule {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
= declareCurrentDclModuleTypes icl_common.com_type_defs typeConversions
o` defineCurrentDclModuleTypes dcl_common.com_cons_defs dcl_common.com_selector_defs dcl_common.com_type_defs typeConversions
*/
defineDclModule
::
ModuleIndex
DclModule
->
BackEnder
defineDclModule
moduleIndex
{
dcl_name
,
dcl_common
,
dcl_functions
,
dcl_instances
}
...
...
@@ -564,7 +593,7 @@ instance declareVars [a] | declareVars a where
=
foldState
(
flip
declareVars
dvInput
)
list
instance
declareVars
(
Ptr
VarInfo
)
where
declareVars
varInfoPtr
_
declareVars
varInfoPtr
_
=
declareVariable
BELhsNodeId
varInfoPtr
"_var???"
// +++ name
instance
declareVars
FreeVar
where
...
...
@@ -704,7 +733,7 @@ foldStateWithIndexRangeA function frm to array
declareArrayInstances
::
IndexRange
Int
{#
FunDef
}
->
BackEnder
declareArrayInstances
{
ir_from
,
ir_to
}
main_dcl_module_n
functions
// | trace_tn ("declareArrayInstances "+++toString ir_from+++" "+++toString ir_to)
=
foldStateWithIndexRangeA
declareArrayInstance
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
}
...
...
@@ -1073,11 +1102,61 @@ convertRule aliasDummyId (index, {fun_type=Yes type, fun_body=body, fun_pos, fun
positionToLineNumber
_
=
-1
beautifyAttributes
::
SymbolType
->
BEMonad
SymbolType
beautifyAttributes
st
=
return
st
// = accAttrHeap (beautifulizeAttributes st)
convertTypeAlt
::
Int
ModuleIndex
SymbolType
->
BEMonad
BETypeAltP
convertTypeAlt
functionIndex
moduleIndex
symbol
=:{
st_result
}
=
beTypeAlt
(
beNormalTypeNode
(
beFunctionSymbol
functionIndex
moduleIndex
)
(
convertSymbolTypeArgs
symbol
))
convertTypeAlt
functionIndex
moduleIndex
symbolType
=
beautifyAttributes
(
symbolType
)
==>
\
symbolType
=:{
st_result
,
st_attr_env
,
st_attr_vars
}
->
resetAttrNumbers
o`
(
beTypeAlt
(
beNormalTypeNode
(
beFunctionSymbol
functionIndex
moduleIndex
)
(
convertSymbolTypeArgs
symbolType
))
(
convertAnnotTypeNode
st_result
)
(
convertAttributeInequalities
(
group
st_attr_env
)))
where
group
::
[
AttrInequality
]
->
[
InequalityGroup
]
group
[]
=
[]
group
[{
ai_demanded
,
ai_offered
}
:
t
]
=
grouped
ai_demanded
[
ai_offered
]
t
// copied grouped from typesupport.icl, apparently inequalities are already sorted by
// offered attributes
// grouped takes care that inequalities like [a<=c, b<=c] are printed like [a b <= c]
grouped
::
AttributeVar
[
AttributeVar
]
[
AttrInequality
]
->
[
InequalityGroup
]
grouped
group_var
accu
[]
=
[{
ig_offered
=
accu
,
ig_demanded
=
group_var
}]
grouped
group_var
accu
[{
ai_offered
,
ai_demanded
}:
ineqs
]
|
group_var
==
ai_demanded
=
grouped
group_var
[
ai_offered
:
accu
]
ineqs
=[{
ig_offered
=
accu
,
ig_demanded
=
group_var
}:
grouped
ai_demanded
[
ai_offered
]
ineqs
]
::
InequalityGroup
=
{
ig_offered
::
![
AttributeVar
]
,
ig_demanded
::
!
AttributeVar
}
resetAttrNumbers
::
*
BackEndState
->
*
BackEndState
resetAttrNumbers
state
=
{
state
&
bes_attr_number
=
0
}
convertAttributeInequalities
::
[
InequalityGroup
]
->
BEMonad
BEUniVarEquations
convertAttributeInequalities
inequalities
=
sfoldr
(
beUniVarEquationsList
o
convertAttributeInequality
)
beNoUniVarEquations
inequalities
convertAttributeInequality
::
InequalityGroup
->
BEMonad
BEUniVarEquations
convertAttributeInequality
{
ig_demanded
,
ig_offered
}
=
beUniVarEquation
(
convertAttributeVar
ig_demanded
)
(
convertAttributeKinds
ig_offered
)
convertAttributeKinds
::
[
AttributeVar
]
->
BEMonad
BEAttributeKindList
convertAttributeKinds
vars
=
sfoldr
(
beAttributeKinds
o
convertAttributeKind
)
beNoAttributeKinds
vars
convertAttributeKind
::
AttributeVar
->
BEMonad
BEAttributeKindList
convertAttributeKind
attributeVar
=
beAttributeKind
(
convertAttributeVar
attributeVar
)
convertSymbolTypeArgs
::
SymbolType
->
BEMonad
BETypeArgP
convertSymbolTypeArgs
{
st_args
}
...
...
@@ -1108,11 +1187,40 @@ convertAnnotation AN_None
convertAnnotation
AN_Strict
=
BEStrictAnnot
convertAttribution
::
TypeAttribute
->
BEAttribution
nextAttributeNumber
::
*
BackEndState
->
(
BEAttribution
,
*
BackEndState
)
nextAttributeNumber
state
=:{
bes_attr_number
}
=
(
bes_attr_number
+
BEFirstUniVarNumber
,
{
state
&
bes_attr_number
=
bes_attr_number
+1
})
convertAttributeVar
::
AttributeVar
*
BackEndState
->
(
BEAttribution
,
*
BackEndState
)
convertAttributeVar
{
av_info_ptr
,
av_name
}
state
=:{
bes_attr_number
}
#
(
attrInfo
,
state
)
=
read_from_attr_heap
av_info_ptr
state
=
case
attrInfo
of
AVI_SequenceNumber
number
->
(
number
,
state
)
_
#
(
attrNumber
,
state
)
=
nextAttributeNumber
state
->
(
attrNumber
,
write_to_attr_heap
av_info_ptr
(
AVI_SequenceNumber
attrNumber
)
state
)
convertAttribution
::
TypeAttribute
->
BEMonad
BEAttribution
convertAttribution
TA_Unique
=
BEUniqueAttr
convertAttribution
_
// +++ uni vars, etc.
=
BENoUniAttr
=
return
BEUniqueAttr
convertAttribution
TA_None
=
return
BENoUniAttr
convertAttribution
TA_Multi
=
return
BENoUniAttr
convertAttribution
TA_Anonymous
=
nextAttributeNumber
convertAttribution
(
TA_Var
attrVar
)
=
convertAttributeVar
attrVar
convertAttribution
(
TA_RootVar
attrVar
)
=
convertAttributeVar
attrVar
convertAttribution
TA_MultiOfPropagatingConsVar
=
return
BENoUniAttr
convertAttribution
attr
=
abort
"backendconvert, convertAttribution: unknown TypeAttribute"
<<-
attr
convertAnnotTypeNode
::
AType
->
BEMonad
BETypeNodeP
convertAnnotTypeNode
{
at_type
,
at_annotation
,
at_attribute
}
...
...
@@ -1139,14 +1247,14 @@ convertTypeNode (TB BT_Dynamic)
convertTypeNode
(
TB
basicType
)
=
beNormalTypeNode
(
beBasicSymbol
(
convertBasicTypeKind
basicType
))
beNoTypeArgs
convertTypeNode
(
TA
typeSymbolIdent
typeArgs
)
=
beNormalTypeNode
(
convertTypeSymbolIdent
typeSymbolIdent
)
(
convertTypeArgs
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
)
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
])
...
...
@@ -1292,8 +1400,8 @@ convertCodeParameter {bind_src, bind_dst}
=
beCodeParameter
bind_src
(
convertVar
(
varInfoPtr
bind_dst
))
/*
convertTransformedLhs :: Int [FreeVar] -> BEMonad BENodeP
convertTransformedLhs functionIndex freeVars
varHeap
= beNormalNode (beFunctionSymbol functionIndex cIclModIndex) (convertLhsArgs freeVars
varHeap
)
convertTransformedLhs functionIndex freeVars
= beNormalNode (beFunctionSymbol functionIndex cIclModIndex) (convertLhsArgs freeVars)
*/
convertPatterns
::
[
FunctionPattern
]
->
BEMonad
BEArgP
...
...
@@ -1341,7 +1449,7 @@ convertRootExpr aliasDummyId (Conditional {if_cond=cond, if_then=then, if_else=Y
(
convertRhsNodeDefs
aliasDummyId
then
main_dcl_module_n
)
(
convertRhsStrictNodeIds
then
)
(
convertRootExpr
aliasDummyId
then
main_dcl_module_n
)
(
convertRhsNodeDefs
aliasDummyId
else
main_dcl_module_n
)
(
convertRhsNodeDefs
aliasDummyId
else
main_dcl_module_n
)
(
convertRhsStrictNodeIds
else
)
(
convertRootExpr
aliasDummyId
else
main_dcl_module_n
)
convertRootExpr
aliasDummyId
(
Conditional
{
if_cond
=
cond
,
if_then
=
then
,
if_else
=
No
})
main_dcl_module_n
...
...
@@ -1577,7 +1685,7 @@ where
convertExpr
(
Conditional
{
if_cond
=
cond
,
if_then
,
if_else
=
Yes
else
})
=
beIfNode
(
convertExpr
cond
)
(
convertExpr
if_then
)
(
convertExpr
else
)
convertExpr
expr
convertExpr
expr
=
undef
<<-
(
"backendconvert, convertExpr: unknown expression"
,
expr
)
convertArgs
::
[
Expression
]
->
BEMonad
BEArgP
...
...
backend/backendinterface.dcl
View file @
bf77a4f7
...
...
@@ -2,4 +2,4 @@ definition module backendinterface
import
frontend
backEndInterface
::
!{#
Char
}
[{#
Char
}]
!
PredefinedSymbols
!
FrontEndSyntaxTree
!
Int
!*
VarHeap
!*
File
!*
Files
->
(!
Bool
,!*
VarHeap
,
!*
File
,
!*
Files
)
backEndInterface
::
!{#
Char
}
[{#
Char
}]
!
PredefinedSymbols
!
FrontEndSyntaxTree
!
Int
!*
VarHeap
!*
AttrVarHeap
!*
File
!*
Files
->
(!
Bool
,
!*
VarHeap
,
!*
AttrVarHeap
,
!*
File
,
!*
Files
)
backend/backendinterface.icl
View file @
bf77a4f7
...
...
@@ -19,8 +19,8 @@ checkVersion VersionObservedIsTooOld 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
backEndInterface
::
!{#
Char
}
[{#
Char
}]
!
PredefinedSymbols
!
FrontEndSyntaxTree
!
Int
!*
VarHeap
!*
AttrVarHeap
!*
File
!*
Files
->
(!
Bool
,
!*
VarHeap
,
!*
AttrVarHeap
,
!*
File
,
!*
Files
)
backEndInterface
outputFileName
commandLineArgs
predef_symbols
syntaxTree
=:{
fe_icl
,
fe_components
}
main_dcl_module_n
var_heap
attrHeap
errorFile
files
#
(
observedCurrent
,
observedOldestDefinition
,
observedOldestImplementation
)
=
BEGetVersion
observedVersion
=
...
...
@@ -42,7 +42,7 @@ backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_i
#
(
compatible
,
errorFile
)
=
checkVersion
(
versionCompare
expectedVersion
observedVersion
)
errorFile
|
not
compatible
=
(
False
,
var_heap
,
errorFile
,
files
)
=
(
False
,
var_heap
,
attrHeap
,
errorFile
,
files
)
#
varHeap
=
backEndPreprocess
predef_symbols
.[
PD_DummyForStrictAliasFun
].
pds_ident
functionIndices
fe_icl
var_heap
with
...
...
@@ -54,10 +54,10 @@ backEndInterface outputFileName commandLineArgs predef_symbols syntaxTree=:{fe_i
=
BEInit
(
length
commandLineArgs
)
backEndFiles
#
backEnd
=
foldState
BEArg
commandLineArgs
backEnd
#
(
var_heap
,
backEnd
)
=
backEndConvertModules
predef_symbols
syntaxTree
main_dcl_module_n
varHeap
backEnd
#
(
var_heap
,
attrHeap
,
backEnd
)
=
backEndConvertModules
predef_symbols
syntaxTree
main_dcl_module_n
varHeap
attrHeap
backEnd
#
(
success
,
backEnd
)
=
BEGenerateCode
outputFileName
backEnd
#
backEndFiles
=
BEFree
backEnd
backEndFiles
=
(
backEndFiles
==
0
&&
success
,
var_heap
,
errorFile
,
files
)
=
(
backEndFiles
==
0
&&
success
,
var_heap
,
attrHeap
,
errorFile
,
files
)
backendC/CleanCompilerSources/backend.c
View file @
bf77a4f7
...
...
@@ -18,6 +18,8 @@
# include "comsupport.h"
/* CurrentModule */
# include "buildtree.h"
/* TupleSymbol, ApplySymbol */
extern
void
InitARC_Info
(
void
);
/* from typeconv.h */
# include "backendsupport.h"
# define Clean(ignore)
...
...
@@ -1155,6 +1157,7 @@ BENormalTypeNode (BESymbolP symbol, BETypeArgP args)
return
(
node
);
}
/* BENormalTypeNode */
BETypeNodeP
BEAttributeTypeNode
(
BEAttribution
attribution
,
BETypeNodeP
typeNode
)
{
...
...
@@ -1164,6 +1167,63 @@ BEAttributeTypeNode (BEAttribution attribution, BETypeNodeP typeNode)
return
(
typeNode
);
}
/* BEAttributeTypeNode */
BEAttributeKindList
BEAttributeKind
(
BEAttribution
attributeKind
)
{
AttributeKindList
new
;
new
=
ConvertAllocType
(
struct
attr_kind_list
);
new
->
akl_elem
=
attributeKind
;
new
->
akl_next
=
NULL
;
return
(
new
);
}
/* BEAttributeKind */
BEAttributeKindList
BENoAttributeKinds
(
void
)
{
return
(
NULL
);
}
/* BENoAttributeKinds */
BEAttributeKindList
BEAttributeKinds
(
BEAttributeKindList
elem
,
BEAttributeKindList
list
)
{
Assert
(
elem
->
akl_next
==
NULL
);
elem
->
akl_next
=
list
;
return
(
elem
);
}
/* BEAttributeKindList */
BEUniVarEquations
BEUniVarEquation
(
BEAttribution
demanded
,
BEAttributeKindList
offered
)
{
UniVarEquations
new
;
new
=
ConvertAllocType
(
struct
uni_var_equats
);
new
->
uve_demanded
=
demanded
;
new
->
uve_offered
=
offered
;
new
->
uve_next
=
NULL
;
return
(
new
);
}
/* BEUniVarEquation */
BEUniVarEquations
BENoUniVarEquations
(
void
)
{
return
(
NULL
);
}
/* BENoUniVarEquations */
BEUniVarEquations
BEUniVarEquationsList
(
BEUniVarEquations
elem
,
BEUniVarEquations
list
)
{
Assert
(
elem
->
uve_next
==
NULL
);
elem
->
uve_next
=
list
;
return
(
elem
);
}
/* BEUniVarEquations */
BETypeNodeP
BEAnnotateTypeNode
(
BEAnnotation
annotation
,
BETypeNodeP
typeNode
)
{
...
...
@@ -1193,7 +1253,7 @@ BETypeArgs (BETypeNodeP node, BETypeArgP nextArgs)
}
/* BETypeArgs */
BETypeAltP
BETypeAlt
(
BETypeNodeP
lhs
,
BETypeNodeP
rhs
)
BETypeAlt
(
BETypeNodeP
lhs
,
BETypeNodeP
rhs
,
BEUniVarEquations
attributeEquations
)
{
TypeAlt
*
alt
;
...
...
@@ -1203,7 +1263,7 @@ BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs)
alt
->
type_alt_rhs
=
rhs
;
alt
->
type_alt_type_context
=
NULL
;
/* used in PrintType */
alt
->
type_alt_attr_equations
=
NULL
;
/* used in PrintType */
alt
->
type_alt_attr_equations
=
attributeEquations
;
/* used in PrintType */
return
(
alt
);
}
/* BETypeAlt */
...
...
@@ -2380,6 +2440,7 @@ BETypeVar (CleanString name)
ident
->
ident_tv
=
typeVar
;
typeVar
->
tv_ident
=
ident
;
typeVar
->
tv_mark
=
0
;
typeVar
->
tv_argument_nr
=
0
;
/* ??? */
return
(
typeVar
);
...
...
@@ -3200,6 +3261,7 @@ BEInit (int argc)
ClearOpenDefinitionModules
();
InitARC_Info
();
InitStatesGen
();