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-and-itasks
sapl-interpreter
Commits
ee8bda56
Commit
ee8bda56
authored
Apr 04, 2016
by
Laszlo Domoszlai
Browse files
update to new SAPL
parent
298ff6ad
Changes
53
Expand all
Hide whitespace changes
Inline
Side-by-side
interpreter/code.c
View file @
ee8bda56
...
...
@@ -15,6 +15,7 @@
#include
"mem.h"
#include
"desc.h"
#include
"gc.h"
#include
"prim.h"
// For compressing the source code a bit
...
...
@@ -58,6 +59,7 @@ void create_thunk_app_static(Code* expr, Thunk** target, int frame_ptr)
assert
(
thunk
->
desc
->
arity
==
expr
->
nr_args
);
for
(
int
i
=
0
;
i
<
expr
->
nr_args
;
i
++
)
{
assert
(((
AppEntry
*
)
expr
)
->
args
[
i
]
->
create_thunk
!=
NULL
);
((
AppEntry
*
)
expr
)
->
args
[
i
]
->
create_thunk
(((
AppEntry
*
)
expr
)
->
args
[
i
],
&
thunk
->
_args
[
i
],
frame_ptr
);
}
}
...
...
@@ -121,6 +123,18 @@ void create_thunk_thunk(Code* expr, Thunk** target, int frame_ptr)
assert
(
!
instackb
(
*
target
));
}
void
create_thunk_select
(
Code
*
expr
,
Thunk
**
target
,
int
frame_ptr
)
{
Thunk
*
thunk
=
(
Thunk
*
)
alloc_heap
(
sizeof
(
AppEntry
)
+
sizeof
(
Thunk
*
)
*
2
);
*
target
=
thunk
;
thunk
->
desc
=
(
Desc
*
)
selectDesc
;
((
SelectEntry
*
)
expr
)
->
expr
->
create_thunk
(((
SelectEntry
*
)
expr
)
->
expr
,
&
thunk
->
_args
[
0
],
frame_ptr
);
thunk
->
_args
[
1
]
=
&
((
SelectEntry
*
)
expr
)
->
idx
;
*
target
=
thunk
;
}
void
set_create_thunk_fun
(
Code
*
code
)
{
switch
(
code
->
type
)
...
...
@@ -147,10 +161,13 @@ void set_create_thunk_fun(Code* code)
case
CT_THUNK
:
code
->
create_thunk
=
create_thunk_thunk
;
break
;
case
CT_SELECT_ADT
:
case
CT_SELECT_LIT
:
case
CT_SELECT_STR
:
case
CT_SELECT_REC
:
case
CT_SELECT
:
code
->
create_thunk
=
create_thunk_select
;
break
;
case
CT_CASE_ADT
:
case
CT_CASE_LIT
:
case
CT_CASE_STR
:
case
CT_CASE_REC
:
case
CT_IF
:
case
CT_LET
:
code
->
create_thunk
=
NULL
;
...
...
@@ -320,7 +337,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
case
CT_APP_FUN
:
{
Desc
*
slice
=
((
AppEntry
*
)
expr
)
->
f
;
int
new_frame_ptr
=
stack_top_a
;
int
argmask
=
1
;
...
...
@@ -421,9 +438,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
while
(
totalArity
>
baseDesc
->
arity
)
{
// must be an FT_FUN
Desc
*
d
=
(
*
bt
)
->
desc
;
int
remainingNrArgs
=
totalArity
-
baseDesc
->
arity
;
slice
=
get_slice
(
baseDesc
,
baseDesc
->
arity
);
...
...
@@ -709,16 +724,16 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
destroy_stack_frame_b
(
root_frame_ptr_b
);
return
;
}
case
CT_SE
LECT
_LIT
:
case
CT_
CA
SE_LIT
:
{
placeholder
();
exec
(((
Select
Entry
*
)
expr
)
->
expr
,
frame_ptr
,
stack_top_a
);
exec
(((
Case
Entry
*
)
expr
)
->
expr
,
frame_ptr
,
stack_top_a
);
Thunk
*
lit
=
pop_a
();
bool
handled
=
false
;
for
(
int
i
=
0
;
i
<
expr
->
nr_cases
;
i
++
)
{
Select
LitCaseEntry
*
caseEntry
=
&
((
Select
Entry
*
)
expr
)
->
cases
[
i
];
Case
LitCaseEntry
*
caseEntry
=
&
((
Case
Entry
*
)
expr
)
->
cases
[
i
];
// NULL means "default", we accept it anyway
if
(
caseEntry
->
lit
!=
NULL
)
...
...
@@ -746,22 +761,44 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
if
(
handled
)
continue
;
if
(((
Select
Entry
*
)
expr
)
->
fallback
!=
NULL
)
if
(((
Case
Entry
*
)
expr
)
->
fallback
!=
NULL
)
{
stack_top_a
-=
((
Select
Entry
*
)
expr
)
->
fallback_nrargs
;
expr
=
((
Select
Entry
*
)
expr
)
->
fallback
;
stack_top_a
-=
((
Case
Entry
*
)
expr
)
->
fallback_nrargs
;
expr
=
((
Case
Entry
*
)
expr
)
->
fallback
;
continue
;
}
abort
(
"no match"
);
}
case
CT_SELECT_STR
:
{
SelectEntry
*
select
=
(
SelectEntry
*
)
expr
;
case
CT_SELECT
:
{
push_a
(
NULL
);
exec
(((
SelectEntry
*
)
expr
)
->
expr
,
frame_ptr
,
stack_top_a
);
Thunk
*
cons
=
pop_a
();
push_a
(
cons
->
_args
[((
SelectEntry
*
)
expr
)
->
idx
.
_int
]);
peek_a
()
->
desc
->
eval
();
Thunk
*
ret
=
pop_a
();
if
(
get_dst
(
root_frame_ptr
)
!=
NULL
&&
ret
->
desc
->
thunk_size
<=
sizeof
(
Thunk
))
{
memcpy
(
get_dst
(
root_frame_ptr
),
ret
,
sizeof
(
Thunk
));
}
else
{
forward_thunk
(
ret
,
root_frame_ptr
);
set_return
(
root_frame_ptr
,
ret
);
}
destroy_stack_frame
(
root_frame_ptr
);
destroy_stack_frame_b
(
root_frame_ptr_b
);
return
;
}
case
CT_CASE_STR
:
{
push_a
(
NULL
);
exec
(
select
->
expr
,
frame_ptr
,
stack_top_a
);
exec
(
((
CaseEntry
*
)
expr
)
->
expr
,
frame_ptr
,
stack_top_a
);
Thunk
*
str
=
pop_a
();
int
length
;
...
...
@@ -781,7 +818,7 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
bool
handled
=
false
;
for
(
int
i
=
0
;
i
<
expr
->
nr_cases
;
i
++
)
{
Select
LitCaseEntry
*
caseEntry
=
&
((
Select
Entry
*
)
expr
)
->
cases
[
i
];
Case
LitCaseEntry
*
caseEntry
=
&
((
Case
Entry
*
)
expr
)
->
cases
[
i
];
// NULL means "default", we accept it anyway
if
(
caseEntry
->
lit
!=
NULL
)
...
...
@@ -807,30 +844,30 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
if
(
handled
)
continue
;
if
(((
Select
Entry
*
)
expr
)
->
fallback
!=
NULL
)
if
(((
Case
Entry
*
)
expr
)
->
fallback
!=
NULL
)
{
stack_top_a
-=
((
Select
Entry
*
)
expr
)
->
fallback_nrargs
;
expr
=
((
Select
Entry
*
)
expr
)
->
fallback
;
stack_top_a
-=
((
Case
Entry
*
)
expr
)
->
fallback_nrargs
;
expr
=
((
Case
Entry
*
)
expr
)
->
fallback
;
continue
;
}
abort
(
"no match"
);
}
case
CT_SE
LECT
_ADT
:
case
CT_
CA
SE_ADT
:
{
Select
Entry
*
select
=
(
Select
Entry
*
)
expr
;
Case
Entry
*
caseEntry
=
(
Case
Entry
*
)
expr
;
push_a
(
NULL
);
exec
(
select
->
expr
,
frame_ptr
,
stack_top_a
);
exec
(
caseEntry
->
expr
,
frame_ptr
,
stack_top_a
);
Thunk
*
cons
=
pop_a
();
expr
=
select
->
bodies
[((
ADTEntry
*
)
cons
->
desc
)
->
idx
];
expr
=
caseEntry
->
bodies
[((
ADTEntry
*
)
cons
->
desc
)
->
idx
];
if
(
expr
!=
NULL
)
{
// Skip the arguments in the case of a default
if
(
!
(
select
->
default_map
&
1
<<
((
ADTEntry
*
)
cons
->
desc
)
->
idx
))
if
(
!
(
caseEntry
->
default_map
&
1
<<
((
ADTEntry
*
)
cons
->
desc
)
->
idx
))
{
for
(
int
i
=
0
;
i
<
cons
->
desc
->
arity
;
i
++
)
{
push_a
(
cons
->
_args
[
i
]);
...
...
@@ -840,25 +877,25 @@ void exec(Code* expr, int frame_ptr, int root_frame_ptr)
continue
;
}
if
(
select
->
fallback
!=
NULL
)
if
(
caseEntry
->
fallback
!=
NULL
)
{
stack_top_a
-=
select
->
fallback_nrargs
;
expr
=
select
->
fallback
;
stack_top_a
-=
caseEntry
->
fallback_nrargs
;
expr
=
caseEntry
->
fallback
;
continue
;
}
abort
(
"no match"
);
}
case
CT_SE
LECT
_REC
:
case
CT_
CA
SE_REC
:
{
Select
Entry
*
select
=
(
Select
Entry
*
)
expr
;
Case
Entry
*
caseEntry
=
(
Case
Entry
*
)
expr
;
push_a
(
NULL
);
exec
(
select
->
expr
,
frame_ptr
,
stack_top_a
);
exec
(
caseEntry
->
expr
,
frame_ptr
,
stack_top_a
);
Thunk
*
cons
=
pop_a
();
expr
=
select
->
bodies
[
0
];
expr
=
caseEntry
->
bodies
[
0
];
if
(
expr
!=
NULL
)
{
...
...
@@ -927,6 +964,7 @@ void eval_hnf()
void
eval_fun
()
{
Thunk
*
thunk
=
peek_a
();
int
frame_ptr
=
stack_top_a
;
int
argmask
=
1
;
...
...
@@ -942,7 +980,7 @@ void eval_fun()
argmask
<<=
1
;
}
exec
(((
FunEntry
*
)
thunk
->
desc
)
->
body
,
frame_ptr
,
frame_ptr
);
exec
(((
FunEntry
*
)
thunk
->
desc
)
->
body
,
frame_ptr
,
frame_ptr
);
}
void
eval_prim
()
...
...
interpreter/code.h
View file @
ee8bda56
...
...
@@ -15,10 +15,11 @@ enum CodeType {
CT_APP_FUN1
,
CT_APP_FUN2
,
CT_APP_FUN_TR
,
// tail recursive
CT_SELECT_ADT
,
CT_SELECT_LIT
,
CT_SELECT_STR
,
CT_SELECT_REC
,
// Record field selection
CT_SELECT
,
CT_CASE_ADT
,
CT_CASE_LIT
,
CT_CASE_STR
,
CT_CASE_REC
,
// Record field selection
CT_IF
,
CT_LET
,
CT_THUNK
// constant, always fits the B stack
...
...
@@ -53,12 +54,18 @@ struct AppEntry {
struct
Code
*
args
[];
};
struct
SelectLitCaseEntry
{
struct
SelectEntry
{
struct
Code
base
;
struct
Code
*
expr
;
Thunk
idx
;
};
struct
CaseLitCaseEntry
{
struct
Code
*
body
;
struct
ThunkEntry
*
lit
;
// NULL -> default
};
struct
Select
Entry
{
struct
Case
Entry
{
struct
Code
base
;
struct
Code
*
expr
;
...
...
@@ -71,7 +78,7 @@ struct SelectEntry {
union
{
struct
Select
LitCaseEntry
cases
[];
struct
Case
LitCaseEntry
cases
[];
struct
Code
*
bodies
[];
};
};
...
...
interpreter/desc.c
View file @
ee8bda56
...
...
@@ -3,6 +3,7 @@
#include
<stdbool.h>
#include
<assert.h>
#include
"debug.h"
#include
"desc.h"
#include
"khash.h"
#include
"mem.h"
...
...
interpreter/main.c
View file @
ee8bda56
...
...
@@ -74,7 +74,7 @@ int main ( int argc, char *argv[] )
parse
(
&
line
,
len
);
input
=
"..
\\
tests
\\
static_os
.bsapl"
;
input
=
"..
\\
tests
\\
jurrien
.bsapl"
;
if
(
argc
==
2
)
{
...
...
interpreter/parse.c
View file @
ee8bda56
...
...
@@ -511,13 +511,13 @@ Code* parseApp(char **ptr, bool dynamic, bool tr) {
}
}
Select
Entry
*
parse
Select
(
char
**
ptr
,
Code
*
fallback
,
int
fallback_nrargs
)
{
Case
Entry
*
parse
Case
(
char
**
ptr
,
Code
*
fallback
,
int
fallback_nrargs
)
{
Code
*
expr
=
parseTerm
(
ptr
);
int
nrCases
;
if
(
!
parseInt
(
ptr
,
&
nrCases
))
return
0
;
struct
Select
Entry
*
entry
=
NULL
;
struct
Case
Entry
*
entry
=
NULL
;
char
type
=
**
ptr
;
...
...
@@ -556,11 +556,11 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
Code
*
firstBody
=
(
Code
*
)
parseFallbackBody
(
ptr
,
child_fallback
,
child_fallback_base_nrargs
+
firstCase
->
arity
);
entry
=
(
Select
Entry
*
)
alloc_code
(
sizeof
(
Select
Entry
)
+
sizeof
(
Code
*
)
*
nrConses
);
entry
=
(
Case
Entry
*
)
alloc_code
(
sizeof
(
Case
Entry
)
+
sizeof
(
Code
*
)
*
nrConses
);
if
(
firstCase
->
type
==
FT_ADT
)
{
entry
->
base
.
type
=
CT_SE
LECT
_ADT
;
entry
->
base
.
type
=
CT_
CA
SE_ADT
;
entry
->
base
.
nr_cases
=
nrConses
;
entry
->
default_map
=
0xFFFFFFFF
;
...
...
@@ -585,15 +585,15 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
}
else
{
entry
->
base
.
type
=
CT_SE
LECT
_REC
;
entry
->
base
.
type
=
CT_
CA
SE_REC
;
entry
->
base
.
nr_cases
=
1
;
entry
->
bodies
[
0
]
=
firstBody
;
}
}
else
{
entry
=
(
Select
Entry
*
)
alloc_code
(
sizeof
(
Select
Entry
)
+
sizeof
(
Select
LitCaseEntry
)
*
nrCases
);
entry
->
base
.
type
=
CT_SE
LECT
_LIT
;
entry
=
(
Case
Entry
*
)
alloc_code
(
sizeof
(
Case
Entry
)
+
sizeof
(
Case
LitCaseEntry
)
*
nrCases
);
entry
->
base
.
type
=
CT_
CA
SE_LIT
;
entry
->
base
.
nr_cases
=
nrCases
;
if
(
isDefault
)
...
...
@@ -610,7 +610,7 @@ SelectEntry* parseSelect(char **ptr, Code* fallback, int fallback_nrargs) {
// String literal is the third case for efficiency reasons
if
(
i
==
0
&&
entry
->
cases
[
i
].
lit
->
thunk
.
desc
==
(
Desc
*
)
__STRING_PTR__
)
{
entry
->
base
.
type
=
CT_SE
LECT
_STR
;
entry
->
base
.
type
=
CT_
CA
SE_STR
;
}
entry
->
cases
[
i
].
body
=
(
Code
*
)
parseFallbackBody
(
ptr
,
child_fallback
,
child_fallback_base_nrargs
);
...
...
@@ -640,10 +640,10 @@ Code* parseFallbackBody(char **ptr, Code* fallback, int fallback_nrargs) {
char
type
=
**
ptr
;
if
(
type
==
'
S
'
)
if
(
type
==
'
C
'
)
{
(
*
ptr
)
++
;
return
(
Code
*
)
parse
Select
(
ptr
,
fallback
,
fallback_nrargs
);
return
(
Code
*
)
parse
Case
(
ptr
,
fallback
,
fallback_nrargs
);
}
else
if
(
type
==
'I'
)
{
...
...
@@ -656,6 +656,18 @@ Code* parseFallbackBody(char **ptr, Code* fallback, int fallback_nrargs) {
}
}
SelectEntry
*
parseSelect
(
char
**
ptr
)
{
struct
SelectEntry
*
entry
=
(
SelectEntry
*
)
alloc_code
(
sizeof
(
SelectEntry
));
entry
->
expr
=
parseTerm
(
ptr
);
entry
->
base
.
type
=
CT_SELECT
;
entry
->
idx
.
desc
=
(
Desc
*
)
__INT__
;
if
(
!
parseInt
(
ptr
,
&
entry
->
idx
.
_int
))
return
0
;
set_create_thunk_fun
((
Code
*
)
entry
);
return
entry
;
}
LetEntry
*
parseLet
(
char
**
ptr
)
{
Code
*
body
=
parseTerm
(
ptr
);
...
...
@@ -713,7 +725,9 @@ Code* parseTerm(char **ptr) {
case
'D'
:
// Dynamic application
return
(
Code
*
)
parseApp
(
ptr
,
true
,
false
);
case
'S'
:
// Select
return
(
Code
*
)
parseSelect
(
ptr
,
NULL
,
0
);
return
(
Code
*
)
parseSelect
(
ptr
);
case
'C'
:
// Case
return
(
Code
*
)
parseCase
(
ptr
,
NULL
,
0
);
case
'I'
:
// If
return
(
Code
*
)
parseIf
(
ptr
,
NULL
,
0
);
case
'E'
:
// Let
...
...
interpreter/prim.c
View file @
ee8bda56
...
...
@@ -372,6 +372,7 @@ void __array_select(int dst_idx)
int
pos
=
readI
(
arg
(
1
));
Thunk
*
elem
=
arr
->
_array
.
_elems
[
pos
];
elem
->
desc
->
eval
();
if
(
target
!=
NULL
)
{
...
...
@@ -583,55 +584,90 @@ void __string_update_copy(int dst_idx)
void
__string_update
(
int
dst_idx
)
{
Thunk
*
target
=
get_dst
(
dst_idx
);
Thunk
*
arr
=
arg
(
3
);
int
idx
=
readI
(
arg
(
2
));
char
elem
=
readC
(
arg
(
1
));
arr
->
_array
.
_chars
[
idx
]
=
(
char
)
elem
;
if
(
target
!=
NULL
)
{
target
->
desc
=
(
Desc
*
)
__FORWARD_PTR__
;
target
->
_forward_ptr
=
arr
;
}
set_return
(
dst_idx
,
arr
);
}
void
__array_update
(
int
dst_idx
)
{
Thunk
*
target
=
get_dst
(
dst_idx
);
Thunk
*
arr
=
arg
(
3
);
int
idx
=
readI
(
arg
(
2
));
Thunk
*
elem
=
arg
(
1
);
arr
->
_array
.
_elems
[
idx
]
=
elem
;
if
(
target
!=
NULL
)
{
target
->
desc
=
(
Desc
*
)
__FORWARD_PTR__
;
target
->
_forward_ptr
=
arr
;
}
set_return
(
dst_idx
,
arr
);
}
void
__array_update_b_i
(
int
dst_idx
)
{
Thunk
*
target
=
get_dst
(
dst_idx
);
Thunk
*
arr
=
arg
(
3
);
int
idx
=
readI
(
arg
(
2
));
int
elem
=
readI
(
arg
(
1
));
arr
->
_array
.
_ints
[
idx
]
=
elem
;
if
(
target
!=
NULL
)
{
target
->
desc
=
(
Desc
*
)
__FORWARD_PTR__
;
target
->
_forward_ptr
=
arr
;
}
set_return
(
dst_idx
,
arr
);
}
void
__array_update_b_b
(
int
dst_idx
)
{
Thunk
*
target
=
get_dst
(
dst_idx
);
Thunk
*
arr
=
arg
(
3
);
int
idx
=
readI
(
arg
(
2
));
int
elem
=
readB
(
arg
(
1
));
arr
->
_array
.
_bools
[
idx
]
=
(
unsigned
char
)
elem
;
if
(
target
!=
NULL
)
{
target
->
desc
=
(
Desc
*
)
__FORWARD_PTR__
;
target
->
_forward_ptr
=
arr
;
}
set_return
(
dst_idx
,
arr
);
}
void
__array_update_b_r
(
int
dst_idx
)
{
Thunk
*
target
=
get_dst
(
dst_idx
);
Thunk
*
arr
=
arg
(
3
);
int
idx
=
readI
(
arg
(
2
));
double
elem
=
readR
(
arg
(
1
));
arr
->
_array
.
_reals
[
idx
]
=
elem
;
if
(
target
!=
NULL
)
{
target
->
desc
=
(
Desc
*
)
__FORWARD_PTR__
;
target
->
_forward_ptr
=
arr
;
}
set_return
(
dst_idx
,
arr
);
}
...
...
@@ -874,7 +910,27 @@ void __abort(int dst_idx)
exit
(
-
1
);
}
void
add_prim
(
int
arity
,
int
boxingMap
,
int
unboxableReturn
,
char
*
name
,
void
(
*
exec
)(
int
))
{
void
__select
(
int
dst_idx
)
{
Thunk
*
target
=
get_dst
(
dst_idx
);
Thunk
*
cons
=
arg
(
2
);
int
idx
=
readI
(
arg
(
1
));
push_a
(
cons
->
_args
[
idx
]);
cons
->
_args
[
idx
]
->
desc
->
eval
();
Thunk
*
ret
=
pop_a
();
if
(
target
!=
NULL
)
{
target
->
desc
=
(
Desc
*
)
__FORWARD_PTR__
;
target
->
_forward_ptr
=
ret
;
}
set_return
(
dst_idx
,
ret
);
}
PrimEntry
*
add_prim
(
int
arity
,
int
boxingMap
,
int
unboxableReturn
,
char
*
name
,
void
(
*
exec
)(
int
))
{
int
nameLength
=
strlen
(
name
);
// before the PrimEntry there are "arity" number of SliceEntries
...
...
@@ -897,6 +953,7 @@ void add_prim(int arity, int boxingMap, int unboxableReturn, char* name, void (
if
(
arity
>
0
)
gen_slices
(
entry_base
,
(
Desc
*
)
entry
,
arity
);
add_desc
(
entry
->
name
,
(
Desc
*
)
entry
);
return
entry
;
}
void
init_prim
()
{
...
...
@@ -995,4 +1052,9 @@ void init_prim() {
add_prim
(
1
,
0
b000
,
0
,
"_trace"
,
&
__trace
);
add_prim
(
1
,
0
b000
,
0
,
"abort"
,
&
__abort
);
selectDesc
=
add_prim
(
2
,
0
b001
,
0
,
"_select"
,
&
__select
);
}
// For lazy select
PrimEntry
*
selectDesc
;
interpreter/prim.h
View file @
ee8bda56
#ifndef __PRIM_H
#define __PRIM_H
#include
"desc.h"
void
init_prim
();
extern
PrimEntry
*
selectDesc
;
#endif // __PRIM_H
\ No newline at end of file
interpreter/thunk.h
View file @
ee8bda56
#ifndef __THUNK_H
#define __THUNK_H
#include
"debug.h"
#include
"desc_base.h"
#define max(a,b) \
...
...
precompiler/precompiler.icl
View file @
ee8bda56
...
...
@@ -3,7 +3,9 @@ module precompiler
import
Sapl
.
SaplParser
import
Sapl
.
SaplTokenizer
import
Sapl
.
Transform
.
Let
import
Sapl
.
Optimization
.
StrictnessPropagation
import
Sapl
.
Transform
.
AddSelectors
import
Lifting
,
Prims
import
StdBool
,
StdList
,
StdOrdList
,
StdFile
,
StdFunc
,
StdArray
,
StdDebug
import
Text
.
StringAppender
,
Text
...
...
@@ -15,6 +17,7 @@ from Text.Unicode.UChar import instance toChar UChar, instance toInt UChar
import
System
.
CommandLine
import
System
.
File
::
TypeInfo
=
Normal
|
Strict
|
UnBoxable
::
VarType
=
Local
Int
TypeInfo
...
...
@@ -25,10 +28,10 @@ import System.File
}
// Fusion of function applications for some very basic cases
simplify
(
SApplication
var1
[
SApplication
var2
args
])
|
unpackVar
var1
==
"not"
&&
unpackVar
var2
==
"eqI"
=
SApplication
(
NormalVar
"neqI"
0
)
args
simplify
(
SApplication
var1
[
SApplication
var2
args
])
|
unpackVar
var1
==
"not"
&&
unpackVar
var2
==
"ltI"
=
SApplication
(
NormalVar
"geI"
0
)
args
simplify
(
SApplication
(
SVar
var1
)
[
SApplication
(
SVar
var2
)
args
])
|
unpackVar
var1
==
"not"
&&
unpackVar
var2
==
"eqI"
=
SApplication
(
SVar
(
NormalVar
"neqI"
0
)
)
args
simplify
(
SApplication
(
SVar
var1
)
[
SApplication
(
SVar
var2
)
args
])
|
unpackVar
var1
==
"not"
&&
unpackVar
var2
==
"ltI"
=
SApplication
(
SVar
(
NormalVar
"geI"
0
)
)
args
simplify
x
=
x
unBoxableType
(
Type
"I"
)
=
True
...
...
@@ -63,7 +66,7 @@ sFunc ctx (FTFunc name body params) a
#
ctx
=
{
ctx
&
vars
=
registerVars
ctx
.
vars
0
params
,
localcount
=
length
params
,
inspine
=
True
,
currentFun
=
(
unpackVar
name
)}
=
a
<++
"F"
<++
sText
(
unpackVar
name
)
<++
sNum
(
length
params
)
<++
sNum
(
calcStrictness
params
0
)
<++
sNum
(
calcBoxing
params
0
)
<++
sTerm
ctx
body
<++
sTerm
ctx
(
addSelectors
body
)
sFunc
ctx
(
FTCAF
name
body
)
a
#
ctx
=
{
ctx
&
inspine
=
False
,
currentFun
=
(
unpackVar
name
)}
...
...
@@ -94,9 +97,13 @@ sTerm ctx t a = sTermS ctx (simplify t) a
where
sTermS
ctx
(
SLit
lit
)
a
=
a
<++
"L"
<++
lit
sTermS
ctx
(
SVar
var
)
a
=
a
<++
sVarApp
ctx
var
sTermS
ctx
(
SApplication
var
terms
)
a
=
a
<++
appType
ctx
var
<++
sNum
(
length
terms
)
<++
sVar
ctx
var
<++
sList0
(
sTerm
{
ctx
&
inspine
=
False
})
terms