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
f00ce5ea
Commit
f00ce5ea
authored
Sep 03, 2001
by
John van Groningen
Browse files
added code for strict and unboxed lists
parent
d84f1330
Changes
19
Hide whitespace changes
Inline
Side-by-side
backendC/CleanCompilerSources/backend.c
View file @
f00ce5ea
...
...
@@ -41,6 +41,9 @@ BEGetVersion (int *current, int *oldestDefinition, int *oldestImplementation)
*
oldestImplementation
=
kBEVersionOldestImplementation
;
}
#if STRICT_LISTS
PolyList
unboxed_record_cons_list
,
unboxed_record_decons_list
;
#endif
extern
PolyList
UserDefinedArrayFunctions
;
/* typechecker.c */
extern
StdOutReopened
,
StdErrorReopened
;
/* cocl.c */
...
...
@@ -494,10 +497,11 @@ BEFunctionSymbol (int functionIndex, int moduleIndex)
Assert
((
unsigned
int
)
functionIndex
<
module
->
bem_nFunctions
);
functionSymbol
=
&
module
->
bem_functions
[
functionIndex
];
Assert
(
functionSymbol
->
symb_kind
==
definition
Assert
(
functionSymbol
->
symb_kind
==
definition
||
functionSymbol
->
symb_kind
==
cons_symb
||
functionSymbol
->
symb_kind
==
nil_symb
||
(
moduleIndex
==
kPredefinedModuleIndex
&&
functionSymbol
->
symb_kind
!=
erroneous_symb
));
functionSymbol
->
symb_def
->
sdef_isused
=
True
;
if
(
functionSymbol
->
symb_kind
!=
cons_symb
&&
functionSymbol
->
symb_kind
!=
nil_symb
)
functionSymbol
->
symb_def
->
sdef_isused
=
True
;
return
(
functionSymbol
);
}
/* BEFunctionSymbol */
...
...
@@ -978,10 +982,10 @@ BEConstructorSymbol (int constructorIndex, int moduleIndex)
if
(
constructorSymbol
->
symb_kind
==
erroneous_symb
)
return
(
constructorSymbol
);
Assert
(
constructorSymbol
->
symb_kind
==
definition
Assert
(
constructorSymbol
->
symb_kind
==
definition
||
constructorSymbol
->
symb_kind
==
cons_symb
||
(
moduleIndex
==
kPredefinedModuleIndex
&&
constructorSymbol
->
symb_kind
!=
erroneous_symb
));
if
(
moduleIndex
!=
kPredefinedModuleIndex
)
if
(
moduleIndex
!=
kPredefinedModuleIndex
&&
constructorSymbol
->
symb_kind
!=
cons_symb
)
constructorSymbol
->
symb_def
->
sdef_isused
=
True
;
return
(
constructorSymbol
);
...
...
@@ -1036,8 +1040,14 @@ BELiteralSymbol (BESymbKind kind, CleanString value)
return
(
symbol
);
}
/* BELiteralSymbol */
# define nid_ref_count_sign nid_scope
#if STRICT_LISTS
void
BEPredefineListConstructorSymbol
(
int
arity
,
int
constructorIndex
,
int
moduleIndex
,
BESymbKind
symbolKind
,
int
head_strictness
,
int
tail_strictness
)
static
SymbolS
unboxed_list_symbols
[
Nr_Of_Predef_Types
][
2
];
static
SymbolP
strict_list_cons_symbols
[
8
];
void
BEPredefineListConstructorSymbol
(
int
constructorIndex
,
int
moduleIndex
,
BESymbKind
symbolKind
,
int
head_strictness
,
int
tail_strictness
)
{
BEModuleP
module
;
SymbolP
symbol_p
;
...
...
@@ -1045,21 +1055,21 @@ void BEPredefineListConstructorSymbol(int arity,int constructorIndex,int moduleI
Assert
(
moduleIndex
==
kPredefinedModuleIndex
);
Assert
((
unsigned
int
)
moduleIndex
<
gBEState
.
be_nModules
);
module
=
&
gBEState
.
be_modules
[
moduleIndex
];
module
=
&
gBEState
.
be_modules
[
moduleIndex
];
Assert
((
unsigned
int
)
constructorIndex
<
module
->
bem_nConstructors
);
symbol_p
=
module
->
bem_constructors
[
constructorIndex
];
Assert
(
symbol_p
->
symb_kind
==
erroneous_symb
);
symbol_p
->
symb_kind
=
symbolKind
;
symbol_p
->
symb_arity
=
arity
;
symbol_p
->
symb_head_strictness
=
head_strictness
;
symbol_p
->
symb_tail_strictness
=
tail_strictness
;
if
(
symbolKind
==
BEConsSymb
&&
head_strictness
<
4
)
strict_list_cons_symbols
[(
head_strictness
<<
1
)
+
tail_strictness
]
=
symbol_p
;
}
void
BEPredefineListTypeSymbol
(
int
typeIndex
,
int
moduleIndex
,
BESymbKind
symbolKind
,
int
head_strictness
,
int
tail_strictness
)
void
BEPredefineListTypeSymbol
(
int
typeIndex
,
int
moduleIndex
,
BESymbKind
symbolKind
,
int
head_strictness
,
int
tail_strictness
)
{
BEModuleP
module
;
SymbolP
symbol_p
;
...
...
@@ -1067,19 +1077,207 @@ void BEPredefineListTypeSymbol(int typeIndex,int moduleIndex,BESymbKind symbolKi
Assert
(
moduleIndex
==
kPredefinedModuleIndex
);
Assert
((
unsigned
int
)
moduleIndex
<
gBEState
.
be_nModules
);
module
=
&
gBEState
.
be_modules
[
moduleIndex
];
module
=
&
gBEState
.
be_modules
[
moduleIndex
];
Assert
((
unsigned
int
)
typeIndex
<
module
->
bem_nTypes
);
symbol_p
=
module
->
bem_types
[
typeIndex
];
Assert
(
symbol_p
->
symb_kind
==
erroneous_symb
);
symbol_p
->
symb_kind
=
symbolKind
;
symbol_p
->
symb_arity
=
1
;
symbol_p
->
symb_kind
=
symbolKind
;
symbol_p
->
symb_arity
=
1
;
symbol_p
->
symb_head_strictness
=
head_strictness
;
symbol_p
->
symb_tail_strictness
=
tail_strictness
;
}
void
BEAdjustStrictListConsInstance
(
int
functionIndex
,
int
moduleIndex
)
{
SymbolP
symbol_p
;
symbol_p
=&
gBEState
.
be_modules
[
moduleIndex
].
bem_functions
[
functionIndex
];
if
(
symbol_p
->
symb_kind
==
definition
){
TypeNode
element_type_p
,
list_type_p
;
SymbDef
sdef
;
TypeArgs
type_args_p
;
sdef
=
symbol_p
->
symb_def
;
type_args_p
=
sdef
->
sdef_rule_type
->
rule_type_rule
->
type_alt_lhs
->
type_node_arguments
;
element_type_p
=
type_args_p
->
type_arg_node
;
list_type_p
=
type_args_p
->
type_arg_next
->
type_arg_node
;
Assert
(
list_type_p
->
type_node_is_var
==
0
);
Assert
(
list_type_p
->
type_node_symbol
->
symb_kind
==
list_type
);
symbol_p
->
symb_head_strictness
=
list_type_p
->
type_node_symbol
->
symb_head_strictness
;
symbol_p
->
symb_tail_strictness
=
list_type_p
->
type_node_symbol
->
symb_tail_strictness
;
if
(
list_type_p
->
type_node_symbol
->
symb_head_strictness
==
3
){
int
element_symbol_kind
;
struct
unboxed_cons
*
unboxed_cons_p
;
Assert
(
element_type_p
->
type_node_is_var
==
0
);
element_symbol_kind
=
element_type_p
->
type_node_symbol
->
symb_kind
;
symbol_p
->
symb_head_strictness
=
4
;
unboxed_cons_p
=
ConvertAllocType
(
struct
unboxed_cons
);
unboxed_cons_p
->
unboxed_cons_sdef_p
=
sdef
;
if
(
element_symbol_kind
<
Nr_Of_Predef_Types
)
unboxed_cons_p
->
unboxed_cons_state_p
=
unboxed_list_symbols
[
element_symbol_kind
][
symbol_p
->
symb_tail_strictness
].
symb_state_p
;
else
if
(
element_symbol_kind
==
definition
&&
element_type_p
->
type_node_symbol
->
symb_def
->
sdef_kind
==
RECORDTYPE
){
PolyList
new_unboxed_record_cons_element
;
SymbDef
record_sdef
;
record_sdef
=
element_type_p
->
type_node_symbol
->
symb_def
;
record_sdef
->
sdef_isused
=
True
;
sdef
->
sdef_isused
=
True
;
unboxed_cons_p
->
unboxed_cons_state_p
=
&
record_sdef
->
sdef_record_state
;
new_unboxed_record_cons_element
=
ConvertAllocType
(
struct
poly_list
);
new_unboxed_record_cons_element
->
pl_elem
=
sdef
;
new_unboxed_record_cons_element
->
pl_next
=
unboxed_record_cons_list
;
unboxed_record_cons_list
=
new_unboxed_record_cons_element
;
sdef
->
sdef_module
=
NULL
;
}
else
unboxed_cons_p
->
unboxed_cons_state_p
=
&
StrictState
;
symbol_p
->
symb_unboxed_cons_p
=
unboxed_cons_p
;
}
}
else
{
Assert
(
symbol_p
->
symb_kind
==
definition
);
debug_message
(
"BEAdjustStrictListInstance: !(symbol_p->symb_kind==definition) %d %d %d
\n
"
,
functionIndex
,
moduleIndex
,
symbol_p
->
symb_kind
);
symbol_p
->
symb_head_strictness
=
0
;
symbol_p
->
symb_tail_strictness
=
0
;
}
symbol_p
->
symb_kind
=
cons_symb
;
/* symbol_p->symb_arity = 2; no symb_arity for cons_symb, because symb_state_p is used of this union */
}
void
BEAdjustUnboxedListDeconsInstance
(
int
functionIndex
,
int
moduleIndex
)
{
SymbolP
symbol_p
,
cons_symbol_p
;
SymbDefP
sdef_p
;
TypeNode
element_type_p
,
list_type_p
;
PolyList
new_unboxed_record_decons_element
;
symbol_p
=&
gBEState
.
be_modules
[
moduleIndex
].
bem_functions
[
functionIndex
];
Assert
(
symbol_p
->
symb_kind
==
definition
);
sdef_p
=
symbol_p
->
symb_def
;
list_type_p
=
sdef_p
->
sdef_rule_type
->
rule_type_rule
->
type_alt_lhs
->
type_node_arguments
->
type_arg_node
;
element_type_p
=
list_type_p
->
type_node_arguments
->
type_arg_node
;
Assert
(
list_type_p
->
type_node_is_var
==
0
);
Assert
(
list_type_p
->
type_node_symbol
->
symb_kind
==
list_type
);
Assert
(
list_type_p
->
type_node_symbol
->
symb_head_strictness
==
3
);
Assert
(
element_type_p
->
type_node_symbol
->
symb_def
->
sdef_kind
==
RECORDTYPE
);
cons_symbol_p
=
ConvertAllocType
(
SymbolS
);
cons_symbol_p
->
symb_kind
=
cons_symb
;
cons_symbol_p
->
symb_head_strictness
=
4
;
cons_symbol_p
->
symb_tail_strictness
=
list_type_p
->
type_node_symbol
->
symb_tail_strictness
;
cons_symbol_p
->
symb_state_p
=&
element_type_p
->
type_node_symbol
->
symb_def
->
sdef_record_state
;
sdef_p
->
sdef_unboxed_cons_symbol
=
cons_symbol_p
;
new_unboxed_record_decons_element
=
ConvertAllocType
(
struct
poly_list
);
new_unboxed_record_decons_element
->
pl_elem
=
sdef_p
;
new_unboxed_record_decons_element
->
pl_next
=
unboxed_record_decons_list
;
unboxed_record_decons_list
=
new_unboxed_record_decons_element
;
}
void
BEAdjustOverloadedNilFunction
(
int
functionIndex
,
int
moduleIndex
)
{
SymbolP
symbol_p
;
symbol_p
=&
gBEState
.
be_modules
[
moduleIndex
].
bem_functions
[
functionIndex
];
symbol_p
->
symb_head_strictness
=
1
;
symbol_p
->
symb_tail_strictness
=
0
;
symbol_p
->
symb_kind
=
nil_symb
;
}
BESymbolP
BEOverloadedConsSymbol
(
int
constructorIndex
,
int
moduleIndex
,
int
deconsIndex
,
int
deconsModuleIndex
)
{
BEModuleP
module
,
decons_module
;
SymbolP
constructor_symbol
,
decons_symbol
,
list_type_symbol
;
TypeNode
list_type
,
element_type
;
Assert
((
unsigned
int
)
deconsModuleIndex
<
gBEState
.
be_nModules
);
decons_module
=
&
gBEState
.
be_modules
[
deconsModuleIndex
];
Assert
((
unsigned
int
)
deconsIndex
<
decons_module
->
bem_nFunctions
);
decons_symbol
=
&
decons_module
->
bem_functions
[
deconsIndex
];
Assert
(
decons_symbol
->
symb_kind
==
definition
);
list_type
=
decons_symbol
->
symb_def
->
sdef_rule_type
->
rule_type_rule
->
type_alt_lhs
->
type_node_arguments
->
type_arg_node
;
element_type
=
list_type
->
type_node_arguments
->
type_arg_node
;
Assert
((
unsigned
int
)
moduleIndex
<
gBEState
.
be_nModules
);
module
=
&
gBEState
.
be_modules
[
moduleIndex
];
Assert
((
unsigned
int
)
constructorIndex
<
module
->
bem_nConstructors
);
constructor_symbol
=
module
->
bem_constructors
[
constructorIndex
];
Assert
(
constructor_symbol
->
symb_kind
==
definition
||
(
moduleIndex
==
kPredefinedModuleIndex
&&
constructor_symbol
->
symb_kind
!=
erroneous_symb
));
if
(
moduleIndex
!=
kPredefinedModuleIndex
)
constructor_symbol
->
symb_def
->
sdef_isused
=
True
;
list_type_symbol
=
list_type
->
type_node_symbol
;
if
(
constructor_symbol
->
symb_head_strictness
==
1
&&
list_type_symbol
->
symb_head_strictness
<
4
)
constructor_symbol
=
strict_list_cons_symbols
[(
list_type_symbol
->
symb_head_strictness
<<
1
)
+
list_type_symbol
->
symb_tail_strictness
];
if
(
list_type_symbol
->
symb_head_strictness
==
3
){
int
element_symbol_kind
;
Assert
(
element_type
->
type_node_is_var
==
0
);
element_symbol_kind
=
element_type
->
type_node_symbol
->
symb_kind
;
if
(
element_symbol_kind
<
Nr_Of_Predef_Types
)
constructor_symbol
=&
unboxed_list_symbols
[
element_symbol_kind
][
list_type_symbol
->
symb_tail_strictness
];
else
if
(
element_symbol_kind
==
definition
&&
element_type
->
type_node_symbol
->
symb_def
->
sdef_kind
==
RECORDTYPE
)
constructor_symbol
=
decons_symbol
->
symb_def
->
sdef_unboxed_cons_symbol
;
}
return
constructor_symbol
;
}
BENodeP
BEOverloadedPushNode
(
int
arity
,
BESymbolP
symbol
,
BEArgP
arguments
,
BENodeIdListP
nodeIds
,
BENodeP
decons_node
)
{
NodeP
push_node
;
push_node
=
ConvertAllocType
(
NodeS
);
push_node
->
node_kind
=
PushNode
;
push_node
->
node_arity
=
arity
;
push_node
->
node_arguments
=
arguments
;
push_node
->
node_push_symbol
=
symbol
;
push_node
->
node_decons_node
=
decons_node
;
push_node
->
node_node_ids
=
nodeIds
;
push_node
->
node_number
=
0
;
Assert
(
arguments
->
arg_node
->
node_kind
==
NodeIdNode
);
Assert
(
arguments
->
arg_node
->
node_node_id
->
nid_ref_count_sign
==
-
1
);
arguments
->
arg_node
->
node_node_id
->
nid_refcount
++
;
return
push_node
;
}
#endif
void
...
...
@@ -1460,9 +1658,6 @@ static int gCurrentScope = 0;
static
NodeIdRefCountListP
gRefCountLists
[
kMaxScope
];
static
NodeIdRefCountListP
gRefCountList
;
# define nid_ref_count_sign nid_scope
static
void
AddRefCount
(
NodeIdP
nodeId
)
{
...
...
@@ -1731,7 +1926,11 @@ BEPushNode (int arity, BESymbolP symbol, BEArgP arguments, BENodeIdListP nodeIds
pushNode
->
node_kind
=
PushNode
;
pushNode
->
node_arity
=
arity
;
pushNode
->
node_arguments
=
arguments
;
#if STRICT_LISTS
pushNode
->
node_push_symbol
=
symbol
;
#else
pushNode
->
node_record_symbol
=
symbol
;
#endif
pushNode
->
node_node_ids
=
nodeIds
;
pushNode
->
node_number
=
0
;
/*
...
...
@@ -1748,6 +1947,7 @@ BEPushNode (int arity, BESymbolP symbol, BEArgP arguments, BENodeIdListP nodeIds
*/
Assert
(
arguments
->
arg_node
->
node_kind
==
NodeIdNode
);
Assert
(
arguments
->
arg_node
->
node_node_id
->
nid_ref_count_sign
==
-
1
);
arguments
->
arg_node
->
node_node_id
->
nid_refcount
++
;
return
(
pushNode
);
...
...
@@ -3229,6 +3429,62 @@ BEArg (CleanString arg)
}
}
/* BEArg */
#if STRICT_LISTS
static
void
init_unboxed_list_symbols
(
void
)
{
StateP
array_state_p
,
strict_array_state_p
,
unboxed_array_state_p
;
int
i
;
for
(
i
=
0
;
i
<
Nr_Of_Predef_Types
;
++
i
){
SymbolP
symbol_p
;
symbol_p
=&
unboxed_list_symbols
[
i
][
0
];
symbol_p
->
symb_kind
=
cons_symb
;
symbol_p
->
symb_head_strictness
=
4
;
symbol_p
->
symb_tail_strictness
=
0
;
symbol_p
->
symb_state_p
=&
BasicSymbolStates
[
i
];
symbol_p
->
symb_next
=
NULL
;
symbol_p
=&
unboxed_list_symbols
[
i
][
1
];
symbol_p
->
symb_kind
=
cons_symb
;
symbol_p
->
symb_head_strictness
=
4
;
symbol_p
->
symb_tail_strictness
=
1
;
symbol_p
->
symb_state_p
=&
BasicSymbolStates
[
i
];
symbol_p
->
symb_next
=
NULL
;
}
array_state_p
=
ConvertAllocType
(
StateS
);
array_state_p
->
state_type
=
ArrayState
;
array_state_p
->
state_arity
=
1
;
array_state_p
->
state_array_arguments
=
ConvertAllocType
(
StateS
);
array_state_p
->
state_mark
=
0
;
SetUnaryState
(
&
array_state_p
->
state_array_arguments
[
0
],
OnA
,
UnknownObj
);
unboxed_list_symbols
[
array_type
][
0
].
symb_state_p
=
array_state_p
;
unboxed_list_symbols
[
array_type
][
1
].
symb_state_p
=
array_state_p
;
strict_array_state_p
=
ConvertAllocType
(
StateS
);
strict_array_state_p
->
state_type
=
ArrayState
;
strict_array_state_p
->
state_arity
=
1
;
strict_array_state_p
->
state_array_arguments
=
ConvertAllocType
(
StateS
);
strict_array_state_p
->
state_mark
=
0
;
strict_array_state_p
->
state_array_arguments
[
0
]
=
StrictState
;
unboxed_list_symbols
[
strict_array_type
][
0
].
symb_state_p
=
strict_array_state_p
;
unboxed_list_symbols
[
strict_array_type
][
1
].
symb_state_p
=
strict_array_state_p
;
unboxed_array_state_p
=
ConvertAllocType
(
StateS
);
unboxed_array_state_p
->
state_type
=
ArrayState
;
unboxed_array_state_p
->
state_arity
=
1
;
unboxed_array_state_p
->
state_array_arguments
=
ConvertAllocType
(
StateS
);
unboxed_array_state_p
->
state_mark
=
STATE_UNBOXED_ARRAY_MASK
;
unboxed_array_state_p
->
state_array_arguments
[
0
]
=
StrictState
;
unboxed_list_symbols
[
unboxed_array_type
][
0
].
symb_state_p
=
unboxed_array_state_p
;
unboxed_list_symbols
[
unboxed_array_type
][
1
].
symb_state_p
=
unboxed_array_state_p
;
}
#endif
BackEnd
BEInit
(
int
argc
)
{
...
...
@@ -3256,6 +3512,10 @@ BEInit (int argc)
#endif
UserDefinedArrayFunctions
=
NULL
;
#if STRICT_LISTS
unboxed_record_cons_list
=
NULL
;
unboxed_record_decons_list
=
NULL
;
#endif
InitPredefinedSymbols
();
...
...
@@ -3266,6 +3526,10 @@ BEInit (int argc)
InitCoding
();
InitInstructions
();
#if STRICT_LISTS
init_unboxed_list_symbols
();
#endif
CheckBEEnumTypes
();
gBEState
.
be_argv
=
ConvertAlloc
((
argc
+
1
)
*
sizeof
(
char
*
));
...
...
backendC/CleanCompilerSources/backend.h
View file @
f00ce5ea
...
...
@@ -209,13 +209,28 @@ Clean (BEBoolSymbol :: Bool BackEnd -> (BESymbolP, BackEnd))
BESymbolP
BELiteralSymbol
(
BESymbKind
kind
,
CleanString
value
);
Clean
(
BELiteralSymbol
::
BESymbKind
String
BackEnd
->
(
BESymbolP
,
BackEnd
))
/*
void BEPredefineListConstructorSymbol (int
arity, int
constructorIndex, int moduleIndex, BESymbKind symbolKind,int head_strictness,int tail_strictness);
Clean (BEPredefineListConstructorSymbol :: Int Int
Int
BESymbKind Int Int BackEnd -> BackEnd)
void
BEPredefineListConstructorSymbol
(
int
constructorIndex
,
int
moduleIndex
,
BESymbKind
symbolKind
,
int
head_strictness
,
int
tail_strictness
);
Clean
(
BEPredefineListConstructorSymbol
::
Int
Int
BESymbKind
Int
Int
BackEnd
->
BackEnd
)
void
BEPredefineListTypeSymbol
(
int
typeIndex
,
int
moduleIndex
,
BESymbKind
symbolKind
,
int
head_strictness
,
int
tail_strictness
);
Clean
(
BEPredefineListTypeSymbol
::
Int
Int
BESymbKind
Int
Int
BackEnd
->
BackEnd
)
*/
void
BEAdjustStrictListConsInstance
(
int
functionIndex
,
int
moduleIndex
);
Clean
(
BEAdjustStrictListConsInstance
::
Int
Int
BackEnd
->
BackEnd
)
void
BEAdjustUnboxedListDeconsInstance
(
int
functionIndex
,
int
moduleIndex
);
Clean
(
BEAdjustUnboxedListDeconsInstance
::
Int
Int
BackEnd
->
BackEnd
)
void
BEAdjustOverloadedNilFunction
(
int
functionIndex
,
int
moduleIndex
);
Clean
(
BEAdjustOverloadedNilFunction
::
Int
Int
BackEnd
->
BackEnd
)
BESymbolP
BEOverloadedConsSymbol
(
int
constructorIndex
,
int
moduleIndex
,
int
deconsIndex
,
int
deconsModuleIndex
);
Clean
(
BEOverloadedConsSymbol
::
Int
Int
Int
Int
BackEnd
->
(
BESymbolP
,
BackEnd
))
BENodeP
BEOverloadedPushNode
(
int
arity
,
BESymbolP
symbol
,
BEArgP
arguments
,
BENodeIdListP
nodeIds
,
BENodeP
decons_node
);
Clean
(
BEOverloadedPushNode
::
Int
BESymbolP
BEArgP
BENodeIdListP
BENodeP
BackEnd
->
(
BENodeP
,
BackEnd
))
void
BEPredefineConstructorSymbol
(
int
arity
,
int
constructorIndex
,
int
moduleIndex
,
BESymbKind
symbolKind
);
Clean
(
BEPredefineConstructorSymbol
::
Int
Int
Int
BESymbKind
BackEnd
->
BackEnd
)
...
...
backendC/CleanCompilerSources/backendsupport.c
View file @
f00ce5ea
...
...
@@ -67,6 +67,29 @@ fatal_backend_error (char *s)
Debugger
();
}
void
debug_message
(
const
char
*
format
,...)
{
va_list
ap
;
va_start
(
ap
,
format
);
vfprintf
(
StdError
,
format
,
ap
);
va_end
(
ap
);
#ifdef _MAC_
{
FILE
*
f
;
f
=
fopen
(
"DebugMessages"
,
"a"
);
if
(
f
!=
NULL
){
va_start
(
ap
,
format
);
vfprintf
(
f
,
format
,
ap
);
va_end
(
ap
);
fclose
(
f
);
}
}
#endif
}
#if 1
/*
Memory management
...
...
backendC/CleanCompilerSources/backendsupport.h
View file @
f00ce5ea
...
...
@@ -13,6 +13,7 @@ extern void AssertionFailed (char *conditionString, char *file, int line);
# define Assert(condition) {if (!(condition)) AssertionFailed ("!(" #condition ")", __FILE__, __LINE__);}
extern
void
fatal_backend_error
(
char
*
s
);
extern
void
debug_message
(
const
char
*
format
,...);
/*
Memory management
...
...
backendC/CleanCompilerSources/codegen.c
View file @
f00ce5ea
...
...
@@ -1191,7 +1191,9 @@ void CodeGeneration (ImpMod imod, char *fname)
GenerateCodeForLazyTupleSelectorEntries
(
LazyTupleSelectors
);
GenerateCodeForLazyArrayFunctionEntries
();
#if STRICT_LISTS
GenerateCodeForLazyUnboxedRecordListFunctions
();
#endif
WriteLastNewlineToABCFile
();
CloseABCFile
(
fname
);
...
...
backendC/CleanCompilerSources/codegen1.c
View file @
f00ce5ea
...
...
@@ -93,6 +93,17 @@ LabDef match_error_lab = {NULL, "", False, "_match_error", 0};
LabDef
conss_lab
=
{
NULL
,
""
,
False
,
"_Conss"
,
0
};
LabDef
consts_lab
=
{
NULL
,
""
,
False
,
"_Consts"
,
0
};
LabDef
conssts_lab
=
{
NULL
,
""
,
False
,
"_Conssts"
,
0
};
LabDef
unboxed_cons_labels
[][
2
]
=
{
/*IntObj*/
{{
NULL
,
""
,
False
,
"_Consi"
,
0
},
{
NULL
,
""
,
False
,
"_Consits"
,
0
}},
/*BoolObj*/
{{
NULL
,
""
,
False
,
"_Consb"
,
0
},
{
NULL
,
""
,
False
,
"_Consbts"
,
0
}},
/*CharObj*/
{{
NULL
,
""
,
False
,
"_Consc"
,
0
},
{
NULL
,
""
,
False
,
"_Conscts"
,
0
}},
/*RealObj*/
{{
NULL
,
""
,
False
,
"_Consr"
,
0
},
{
NULL
,
""
,
False
,
"_Consrts"
,
0
}},
/*FileObj*/
{{
NULL
,
""
,
False
,
"_Consf"
,
0
},
{
NULL
,
""
,
False
,
"_Consfts"
,
0
}}
};
LabDef
unboxed_cons_array_label
=
{
NULL
,
""
,
False
,
"_Consa"
,
0
};
#endif
#ifdef CLEAN2
LabDef
select_with_dictionary_lab
=
{
NULL
,
""
,
False
,
"_select_with_dictionary"
,
0
};
...
...
@@ -688,7 +699,7 @@ static void CopyEntry (int offset, int *sp, int offframe [])
GenPushA
(
*
sp
-
offset
);
else
GenPushB
(
*
sp
-
offset
);
(
*
sp
)
++
;
++
*
sp
;
UpdateFrame
(
offframe
,
*
sp
,
offframe
[
offset
],
offframe
);
}
...
...
@@ -1107,46 +1118,109 @@ static void GenLazyFieldSelectorEntry (SymbDef field_def,StateS recstate,int tot
}
}
static
void
Gen
LazyArrayFunction
(
SymbDef
arr_
fun_def
)
static
void
Gen
UnboxedRecordApplyAndNodeEntries
(
SymbDef
fun_def
,
int
n_result_nodes_on_a_stack
,
int
*
a_size_p
,
int
*
b_size_p
)
{
LabDef
ealab
;
int
asize
,
bsize
,
maxasize
;
RuleTypes
af
_type
;
RuleTypes
rule
_type
;
int
arity
;
asize
=
0
;
bsize
=
0
;
maxasize
=
0
;
af
_type
=
arr_
fun_def
->
sdef_rule_type
;
arity
=
arr_
fun_def
->
sdef_arity
;
rule
_type
=
fun_def
->
sdef_rule_type
;
arity
=
fun_def
->
sdef_arity
;
MakeSymbolLabel
(
&
CurrentAltLabel
,
NULL
,
no_pref
,
arr_
fun_def
,
0
);
MakeSymbolLabel
(
&
CurrentAltLabel
,
NULL
,
no_pref
,
fun_def
,
0
);
ealab
=
CurrentAltLabel
;
ealab
.
lab_pref
=
ea_pref
;
AddStateSizesAndMaxFrameSizes
(
arity
,
af
_type
->
rule_type_state_p
,
&
maxasize
,
&
asize
,
&
bsize
);
AddStateSizesAndMaxFrameSizes
(
arity
,
rule
_type
->
rule_type_state_p
,
&
maxasize
,
&
asize
,
&
bsize
);
if
((
arr_
fun_def
->
sdef_mark
&
SDEF_USED_CURRIED_MASK
)
||
DoDescriptors
||
DoParallel
)
GenArrayFunctionDescriptor
(
arr_
fun_def
,
&
CurrentAltLabel
,
arity
);
if
((
fun_def
->
sdef_mark
&
SDEF_USED_CURRIED_MASK
)
||
DoDescriptors
||
DoParallel
)
GenArrayFunctionDescriptor
(
fun_def
,
&
CurrentAltLabel
,
arity
);
if
(
DoTimeProfiling
)
GenPB
(
arr_
fun_def
->
sdef_ident
->
ident_name
);
GenPB
(
fun_def
->
sdef_ident
->
ident_name
);
if
(
arr_
fun_def
->
sdef_mark
&
SDEF_USED_CURRIED_MASK
)
ApplyEntry
(
af
_type
->
rule_type_state_p
,
arity
,
&
ealab
,
!
(
arr_
fun_def
->
sdef_mark
&
SDEF_USED_LAZILY_MASK
));
if
(
fun_def
->
sdef_mark
&
SDEF_USED_CURRIED_MASK
)
ApplyEntry
(
rule
_type
->
rule_type_state_p
,
arity
,
&
ealab
,
!
(
fun_def
->
sdef_mark
&
SDEF_USED_LAZILY_MASK
));
if
(
arr_
fun_def
->
sdef_mark
&
SDEF_USED_LAZILY_MASK
)
NodeEntry
(
af
_type
->
rule_type_state_p
,
arity
,
&
ealab
,
arr_
fun_def
);
if
(
fun_def
->
sdef_mark
&
SDEF_USED_LAZILY_MASK
)
NodeEntry
(
rule
_type
->
rule_type_state_p
,
arity
,
&
ealab
,
fun_def
);
EvalArgsEntry
(
af_type
->
rule_type_state_p
,
arr_fun_def
,
maxasize
,
&
ealab
,
0
);
EvalArgsEntry
(
rule_type
->
rule_type_state_p
,
fun_def
,
maxasize
,
&
ealab
,
n_result_nodes_on_a_stack
);
*
a_size_p
=
asize
;
*
b_size_p
=
bsize
;
}
CallArrayFunction
(
arr_fun_def
,
False
,
&
af_type
->
rule_type_state_p
[
-
1
]);
#if STRICT_LISTS
extern
PolyList
unboxed_record_cons_list
,
unboxed_record_decons_list
;
if
(
DoTimeProfiling
)
GenPE
();
void
GenerateCodeForLazyUnboxedRecordListFunctions
(
void
)
{
PolyList
unboxed_record_cons_elem
,
unboxed_record_decons_elem
;
for_l
(
unboxed_record_cons_elem
,
unboxed_record_cons_list
,
pl_next
){
SymbDef
fun_def
;
fun_def
=
unboxed_record_cons_elem
->
pl_elem
;
if
(
fun_def
->
sdef_mark
&
(
SDEF_USED_LAZILY_MASK
|
SDEF_USED_CURRIED_MASK
)){
int
a_size
,
b_size
;
TypeArgs
type_node_arguments_p
;
LabDef
unboxed_record_cons_lab
;
int
tail_strict
;