Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
C
clean-sapl
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
2
Issues
2
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
clean-and-itasks
clean-sapl
Commits
2d912c78
Commit
2d912c78
authored
Apr 26, 2016
by
Laszlo Domoszlai
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
"update" syntax
parent
8de10300
Changes
10
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
258 additions
and
102 deletions
+258
-102
src/Sapl/Optimization/StrictnessPropagation.icl
src/Sapl/Optimization/StrictnessPropagation.icl
+8
-2
src/Sapl/SaplParser.icl
src/Sapl/SaplParser.icl
+33
-7
src/Sapl/SaplStruct.dcl
src/Sapl/SaplStruct.dcl
+2
-1
src/Sapl/SaplTokenizer.dcl
src/Sapl/SaplTokenizer.dcl
+5
-1
src/Sapl/SaplTokenizer.icl
src/Sapl/SaplTokenizer.icl
+12
-7
src/Sapl/Target/JS/CodeGeneratorJS.icl
src/Sapl/Target/JS/CodeGeneratorJS.icl
+64
-11
src/Sapl/Target/JS/Lifting.dcl
src/Sapl/Target/JS/Lifting.dcl
+5
-2
src/Sapl/Target/JS/Lifting.icl
src/Sapl/Target/JS/Lifting.icl
+125
-68
src/Sapl/Transform/AddSelectors.icl
src/Sapl/Transform/AddSelectors.icl
+2
-2
src/Sapl/Transform/Let.icl
src/Sapl/Transform/Let.icl
+2
-1
No files found.
src/Sapl/Optimization/StrictnessPropagation.icl
View file @
2d912c78
...
...
@@ -49,7 +49,13 @@ where
walk
sd
t
=:(
SVar
var
)
=
(
insert
(
unpackVar
var
)
sd
,
t
)
// We can skip the new expr, cannot contain let definitions...
walk
sd
t
=:(
SSelect
expr
idx
)
walk
sd
t
=:(
SUpdate
expr
_
updates
)
#
(
sd
,
_)
=
walk
sd
expr
// TODO: updates
=
(
sd
,
t
)
// We can skip the new expr, cannot contain let definitions...
walk
sd
t
=:(
SSelect
expr
_
idx
)
#
(
sd
,
_)
=
walk
sd
expr
=
(
sd
,
t
)
...
...
@@ -64,7 +70,7 @@ where
strictArgs
=
map
fst
(
filter
checkArg
(
zip2
args
[
0
..]))
// We can skip the new expr, cannot contain let definitions...
// Args cannot be checked, we do not know the function defiition...
// Args cannot be checked, we do not know the function defi
n
ition...
walk
sd
t
=:(
SApplication
expr
args
)
// expr is always strict
#
(
sd
,
_)
=
walk
sd
expr
...
...
src/Sapl/SaplParser.icl
View file @
2d912c78
...
...
@@ -66,6 +66,9 @@ addTupleCons _ = returnS Void
read_int
[
TLit
(
LInt
lit
):
ts
]
=
returnS
(
Just
lit
,
ts
)
read_int
ts
=
returnS
(
Nothing
,
ts
)
type
[
TTypeDef
,
TIdentifier
type
:
ts
]
=
returnS
(
Type
type
,
ts
)
type
ts
=
returnS
(
NoType
,
ts
)
expr
[
TOpenParenthesis
:
ts
]
=
mexpr
ts
>>=
\(
t
,
ts
)
=
case
hd
ts
of
...
...
@@ -86,12 +89,35 @@ expr [TIdentifier name:ts] =
expr
[
TSelectKeyword
:
ts
]
=
sexpr
ts
>>=
mandatory
"Missing select expression"
>>=
\(
expr
,
ts
)
=
read_int
ts
>>=
\(
expr
,
ts
)
=
type
ts
>>=
\(
ty
,
ts
)
=
read_int
ts
>>=
mandatory
"Missing select index"
>>=
\(
idx
,
ts
)
=
args_expr
ts
>>=
\(
as
,
ts
)
=
case
as
of
[]
=
returnS
(
Just
(
SSelect
expr
idx
),
ts
)
=
returnS
(
Just
(
SApplication
(
SSelect
expr
idx
)
as
),
ts
)
[]
=
returnS
(
Just
(
SSelect
expr
ty
idx
),
ts
)
=
returnS
(
Just
(
SApplication
(
SSelect
expr
ty
idx
)
as
),
ts
)
expr
[
TUpdateKeyword
:
ts
]
=
sexpr
ts
>>=
mandatory
"Missing update expression"
>>=
\(
expr
,
ts
)
=
type
ts
>>=
\(
ty
,
ts
)
=
upd_list
ts
>>=
\(
upds
,
ts
)
=
returnS
(
Just
(
SUpdate
expr
ty
upds
),
ts
)
where
upd_list
[
TOpenSquareBracket
:
ts
]
=
update_1
ts
[]
>>=
\(
us
,
ts
)
=
case
hd
ts
of
TCloseSquareBracket
=
returnS
(
us
,
tl
ts
)
=
returnE
(
ts
,
"Missing close square bracket"
)
upd_list
ts
=
returnE
(
ts
,
"Missing open bracket"
)
update_1
[
TLit
(
LInt
idx
),
TColon
:
ts
]
as
=
expr
ts
>>=
mandatory
"Missing field update expression"
>>=
\(
expr
,
ts
)
=
update_2
ts
[(
idx
,
expr
):
as
]
update_1
ts
as
=
returnE
(
ts
,
"Invalid field
\"
update
\"
"
)
update_2
[
TComma
:
ts
]
as
=
update_1
ts
as
update_2
ts
as
=
returnS
(
reverse
as
,
ts
)
expr
ts
=
returnS
(
Nothing
,
ts
)
...
...
@@ -132,7 +158,7 @@ where
>>=
\
level
=
body
False
ts
>>=
\(
t
,
ts
)
=
letdef_2
ts
[
SaplLetDef
(
TypedVar
(
StrictVar
name
level
)
NoType
)
t
:
as
]
letdef_1
ts
as
=
returnE
(
ts
,
"Invalid
\"
let
\"
definition"
)
letdef_2
[
TCo
lon
:
ts
]
as
=
letdef_1
ts
as
letdef_2
[
TCo
mma
:
ts
]
as
=
letdef_1
ts
as
letdef_2
ts
as
=
returnS
(
reverse
as
,
ts
)
body
simple
[
TOpenParenthesis
:
ts
]
=
...
...
@@ -220,7 +246,7 @@ where
args_1
[
TStrictIdentifier
name
,
TTypeDef
,
TIdentifier
type
:
ts
]
as
=
getLevel
>>=
\
level
=
args_2
ts
[
TypedVar
(
StrictVar
name
level
)
(
Type
type
):
as
]
args_1
[
TStrictIdentifier
name
:
ts
]
as
=
getLevel
>>=
\
level
=
args_2
ts
[
TypedVar
(
StrictVar
name
level
)
NoType
:
as
]
args_1
ts
as
=
returnE
(
ts
,
"Missing argument"
)
args_2
[
TCo
lon
:
ts
]
as
=
args_1
ts
as
args_2
[
TCo
mma
:
ts
]
as
=
args_1
ts
as
args_2
ts
as
=
returnS
(
reverse
as
,
ts
)
args_adt
ts
=
args_1
ts
[]
0
...
...
@@ -291,7 +317,7 @@ parse pts
#
ts
=
map
(\(
PosToken
_
_
t
)
=
t
)
pts
=
case
(
program
ts
[])
defaultState
of
Ok
((
fts
,
_),
ps
)
=
Ok
(
ps
.
ps_genFuns
++
fts
,
ps
)
Error
(
ts
,
msg
)
=
let
(
lp
,
cp
)
=
findpos
ts
in
Error
(
msg
+++
" at line "
+++
toString
lp
+++
" before charac
h
ter "
+++
toString
cp
)
Error
(
ts
,
msg
)
=
let
(
lp
,
cp
)
=
findpos
ts
in
Error
(
msg
+++
" at line "
+++
toString
lp
+++
" before character "
+++
toString
cp
)
where
findpos
rest_ts
#
rest_pts
=
drop
((
length
pts
)-(
length
rest_ts
)
-1
)
pts
...
...
@@ -303,7 +329,7 @@ parseExpr pts
#
ts
=
map
(\(
PosToken
_
_
t
)
=
t
)
pts
=
case
(
body
False
ts
)
defaultState
of
Ok
((
fts
,
_),
ps
)
=
Ok
(
fts
,
ps
)
Error
(
ts
,
msg
)
=
let
(
lp
,
cp
)
=
findpos
ts
in
Error
(
msg
+++
" at line "
+++
toString
lp
+++
" before charac
h
ter "
+++
toString
cp
)
Error
(
ts
,
msg
)
=
let
(
lp
,
cp
)
=
findpos
ts
in
Error
(
msg
+++
" at line "
+++
toString
lp
+++
" before character "
+++
toString
cp
)
where
findpos
rest_ts
#
rest_pts
=
drop
((
length
pts
)-(
length
rest_ts
)
-1
)
pts
...
...
src/Sapl/SaplStruct.dcl
View file @
2d912c78
...
...
@@ -20,7 +20,8 @@ import Data.Maybe
|
SApplication
SaplTerm
[
SaplTerm
]
|
SCase
SaplTerm
[(
SaplPattern
,
SaplTerm
)]
|
SLet
SaplTerm
[
SaplLetDef
]
|
SSelect
SaplTerm
Int
|
SSelect
SaplTerm
SaplType
Int
|
SUpdate
SaplTerm
SaplType
[(
Int
,
SaplTerm
)]
|
SAbortBody
::
SaplLetDef
=
SaplLetDef
SaplTypedVar
SaplTerm
...
...
src/Sapl/SaplTokenizer.dcl
View file @
2d912c78
...
...
@@ -14,16 +14,20 @@ import StdString, Text.Unicode
|
TMacroAssignmentOp
|
TCAFAssignmentOp
|
TLambda
|
TComma
|
TColon
|
TVerticalBar
|
TOpenParenthesis
|
TCloseParenthesis
|
TOpenBracket
|
TCloseBracket
|
TOpenSquareBracket
|
TCloseSquareBracket
|
TTypeDef
|
TLit
Literal
|
TCaseKeyword
|
TSelectKeyword
|
TSelectKeyword
|
TUpdateKeyword
|
TLetKeyword
|
TInKeyword
|
TEndOfLine
...
...
src/Sapl/SaplTokenizer.icl
View file @
2d912c78
...
...
@@ -10,7 +10,7 @@ is_stopchar :: !Char -> Bool
is_stopchar
char
=
(
char
==
'='
)
||
(
char
==
':'
)
||
(
char
==
')'
)
||
(
char
==
'('
)
||
(
char
==
'|'
)
||
(
char
==
'{'
)
||
(
char
==
'}'
)
||
(
char
==
','
)
||
(
char
==
'
;
'
)
||
isSpace
char
(
char
==
'
['
)
||
(
char
==
']
'
)
||
isSpace
char
not_stopchar
=
not
o
is_stopchar
is_space
c
=
isSpace
c
&&
not_eol
c
...
...
@@ -78,7 +78,7 @@ read_token :: !Int !String -> (!Int, !Int, !Token)
read_token
base
line
|
start
>
((
size
line
)
-1
)
=
rnoarg
TEndOfLine
0
|
matchCharAt
'
;'
line
start
||
matchCharAt
'
\n'
line
start
|
matchCharAt
'\n'
line
start
=
rnoarg
TEndOfLine
1
// Skip <{ and }> from the identifier. It's to help parsing "strange" function names
|
matchAt
"!<{"
line
start
...
...
@@ -102,10 +102,10 @@ read_token base line
=
rnoarg
TMacroAssignmentOp
3
|
matchAt
"->"
line
start
=
rnoarg
TCaseAssignmentOp
2
|
matchCharAt
'\\'
line
start
=
rnoarg
TLambda
1
|
matchCharAt
','
line
start
=
rnoarg
TColon
1
=
rnoarg
TComma
1
|
matchCharAt
':'
line
start
=
rnoarg
TColon
1
|
matchCharAt
'('
line
start
=
rnoarg
TOpenParenthesis
1
|
matchCharAt
')'
line
start
...
...
@@ -114,6 +114,10 @@ read_token base line
=
rnoarg
TOpenBracket
1
|
matchCharAt
'}'
line
start
=
rnoarg
TCloseBracket
1
|
matchCharAt
'['
line
start
=
rnoarg
TOpenSquareBracket
1
|
matchCharAt
']'
line
start
=
rnoarg
TCloseSquareBracket
1
|
matchCharAt
'"'
line
start
#
(
nextbase
,
ustr
)
=
read_string_lit
'"'
(
start
+1
)
line
=
return
(
TLit
(
LString
ustr
),
nextbase
)
...
...
@@ -138,6 +142,7 @@ read_token base line
"true"
=
return
(
TLit
(
LBool
True
),
stop
)
"case"
=
return
(
TCaseKeyword
,
stop
)
"select"
=
return
(
TSelectKeyword
,
stop
)
"update"
=
return
(
TUpdateKeyword
,
stop
)
"let"
=
return
(
TLetKeyword
,
stop
)
"in"
=
return
(
TInKeyword
,
stop
)
str
=
if
(
str
.[
0
]
==
'!'
)
...
...
@@ -216,8 +221,8 @@ where
toString
TAssignmentOp
=
"="
toString
TMacroAssignmentOp
=
":=="
toString
TCAFAssignmentOp
=
"=:"
toString
T
Lambda
=
"
\\
"
toString
TColon
=
"
,
"
toString
T
Comma
=
",
"
toString
TColon
=
"
:
"
toString
TVerticalBar
=
"|"
toString
TOpenParenthesis
=
"("
toString
TCloseParenthesis
=
")"
...
...
src/Sapl/Target/JS/CodeGeneratorJS.icl
View file @
2d912c78
...
...
@@ -16,6 +16,7 @@ import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimizati
import
Sapl
.
Transform
.
Let
import
Sapl
.
Target
.
JS
.
Lifting
import
Sapl
.
Transform
.
AddSelectors
import
StdDebug
from
Data
.
List
import
elem_by
,
partition
...
...
@@ -109,6 +110,17 @@ isTailRecursive var (SApplication (SVar avar) _) = unpackVar var == unpackVar av
isTailRecursive
var
(
SLet
body
_)
=
isTailRecursive
var
body
isTailRecursive
_
_
=
False
strictnessMap
::
!
SaplType
!
CoderState
->
Int
strictnessMap
NoType
_
=
0
strictnessMap
(
Type
cons
)
{
cs_constructors
}
=
case
get
cons
cs_constructors
of
Nothing
=
0
(
Just
{
args
})
=
toInt
args
0
where
toInt
[]
_
=
0
toInt
[
TypedVar
(
StrictVar
_
_)
_:
as
]
i
=
(
toInt
as
(
i
+1
))
bitor
(
2
<<
i
)
toInt
[
TypedVar
(
NormalVar
_
_)
_:
as
]
i
=
toInt
as
(
i
+1
)
funcCoder
::
!
FuncType
!
CoderState
!
StringAppender
->
StringAppender
funcCoder
(
FTFunc
name
body
args
)
s
a
=
normalFunc
name
(
addSelectors
body
)
args
s
a
funcCoder
(
FTMacro
name
body
args
)
s
a
=
normalFunc
name
body
args
s
a
...
...
@@ -569,13 +581,32 @@ where
=
a
<++
escapeName
s
.
cs_prefix
(
unpackVar
fa
)
<++
"=t"
<++
i
<++
";"
<++
mta_2
fargs
(
i
+1
)
s
// skip level information for TR!
mta_2
[]
i
s
a
=
a
forceTermCoder
(
SApplication
sel
=:(
SSelect
_
_)
args
)
s
a
forceTermCoder
(
SApplication
sel
=:(
SSelect
_
_
_
)
args
)
s
a
=
a
<++
"Sapl.fapp("
<++
forceTermCoder
sel
s
<++
",["
<++
termArrayCoder
args
","
s
<++
"])"
forceTermCoder
t
=:(
SSelect
expr
idx
)
s
a
=
a
<++
"Sapl.feval("
<++
forceTermCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
"["
<++
idx
+
2
<++
"])"
forceTermCoder
t
=:(
SSelect
expr
type
idx
)
s
a
|
isStrict
idx
=
a
<++
forceTermCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
"["
<++
idx
+
2
<++
"]"
=
a
<++
"Sapl.feval("
<++
forceTermCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
"["
<++
idx
+
2
<++
"])"
where
strictness
=
strictnessMap
type
s
isStrict
idx
=
(
strictness
bitand
(
2
<<
idx
))
>
0
// It is always in a strict let bind
forceTermCoder
t
=:(
SUpdate
expr
type
updates
)
s
a
=
a
<++
"var "
<++
termCoder
var
{
s
&
cs_inletbind
=
Nothing
,
cs_futuredefs
=
[]}
<++
"="
<++
forceTermCoder
expr
{
s
&
cs_inletbind
=
Nothing
}
<++
".slice(0);"
<++
genUpd
updates
;
where
var
=
fromJust
s
.
cs_inletbind
strictness
=
strictnessMap
type
s
isStrict
idx
=
(
strictness
bitand
(
2
<<
idx
))
>
0
genUpd
[]
a
=
a
genUpd
[(
idx
,
expr
):
us
]
a
=
a
<++
termCoder
var
{
s
&
cs_inletbind
=
Nothing
,
cs_futuredefs
=
[]}
<++
"["
<++
idx
+
2
<++
"]="
<++
(
if
(
isStrict
idx
)
forceTermCoder
termCoder
)
expr
{
s
&
cs_inletbind
=
Nothing
}
<++
";"
<++
genUpd
us
forceTermCoder
t
s
a
=
termCoder
t
s
a
...
...
@@ -604,8 +635,17 @@ where
termCoder
::
!
SaplTerm
!
CoderState
!
StringAppender
->
StringAppender
termCoder
t
=:(
SVar
var
)
s
a
=
termCoder
var
s
a
termCoder
t
=:(
SSelect
expr
idx
)
s
a
=
a
<++
"[Sapl.select,["
<++
termCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
", "
<++
idx
+
2
<++
"]]"
termCoder
t
=:(
SSelect
expr
type
idx
)
s
a
|
isStrict
idx
=
a
<++
"[Sapl.sselect,["
<++
termCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
", "
<++
idx
+
2
<++
"]]"
=
a
<++
"[Sapl.select,["
<++
termCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
", "
<++
idx
+
2
<++
"]]"
where
strictness
=
strictnessMap
type
s
isStrict
idx
=
(
strictness
bitand
(
2
<<
idx
))
>
0
// Should not happen, at thi spoint "update" is always at strict position
termCoder
t
=:(
SUpdate
_
_
_)
s
a
=
a
<++
"/* UPD */"
termCoder
t
=:(
SCase
expr
patterns
)
s
a
|
any
(
isConsPattern
o
fst
)
patterns
#
a
=
a
<++
"var ys="
<++
forceTermCoder
expr
{
s
&
cs_intrfunc
=
Nothing
}
<++
";"
...
...
@@ -680,7 +720,7 @@ where
inlineFun
=
fromJust
mbInlineFun
// Dynamic application: fun part is always strict
termCoder
(
SApplication
sel
=:(
SSelect
_
_)
args
)
s
a
termCoder
(
SApplication
sel
=:(
SSelect
_
_
_
)
args
)
s
a
=
a
<++
"["
<++
forceTermCoder
sel
s
<++
",["
<++
termArrayCoder
args
","
s
<++
"]]"
...
...
@@ -724,18 +764,31 @@ generateJS f tramp saplsrc mbPst
#
state
=
newState
f
tramp
newpst
#
a
=
newAppender
<++
"
\"
use strict
\"
;"
#
a
=
a
<++
"/*Trampoline: "
#
a
=
if
tramp
(
a
<++
"ON"
)
(
a
<++
"OFF"
)
#
a
=
foldl
(\
a
curr
=
a
<++
funcCoder
curr
state
)
(
a
<++
"*/"
)
(
map
prepareFun
funcs
)
#
a
=
if
tramp
(
a
<++
"ON"
)
(
a
<++
"OFF"
)
// Lift + generated update functions
#
(
funcs
,
genfuns
)
=
foldl
(
upd
(
isStrictArgFlavour
f
newpst
))
([],
newMap
)
funcs
#
funcs
=
reverse
funcs
++
elems
genfuns
#
a
=
foldl
(\
a
curr
=
a
<++
funcCoder
curr
state
)
(
a
<++
"*/"
)
funcs
=
Ok
(
a
,
newpst
)
Error
msg
=
Error
msg
Error
msg
=
Error
msg
where
upd
::
(!
String
!
Int
!
Int
->
Bool
)
([
FuncType
],
Map
String
FuncType
)
FuncType
->
([
FuncType
],
Map
String
FuncType
)
upd
sf
(
nfs
,
genfuns
)
fun
=
let
(
nfun
,
ngenfuns
)
=
prepareFun
sf
fun
genfuns
in
([
nfun
:
nfs
],
union
genfuns
ngenfuns
)
exprGenerateJS
::
!
Flavour
!
Bool
!
String
!(
Maybe
ParserState
)
!
StringAppender
->
(
MaybeErrorString
(
String
,
StringAppender
,
ParserState
))
exprGenerateJS
f
tramp
saplsrc
mbPst
out
#
pts
=
tokensWithPositions
saplsrc
=
case
parseExpr
pts
of
Ok
(
body
,
s
)
#
newpst
=
mergeParserStates
s
mbPst
#
state
=
newState
f
tramp
newpst
#
a
=
termCoder
(
prepareExpr
body
)
{
state
&
cs_inbody
=
Just
(
TypedVar
(
NormalVar
"__dummy"
0
)
NoType
)}
newAppender
// Lift + generated update functions. TODO: do not skip generated functions
#
(
body
,
_)
=
prepareExpr
(
isStrictArgFlavour
f
newpst
)
body
newMap
#
a
=
termCoder
body
{
state
&
cs_inbody
=
Just
(
TypedVar
(
NormalVar
"__dummy"
0
)
NoType
)}
newAppender
#
out
=
foldl
(\
a
curr
=
a
<++
funcCoder
curr
state
)
out
s
.
ps_genFuns
=
Ok
(
toString
a
,
out
,
newpst
)
Error
msg
=
Error
msg
...
...
src/Sapl/Target/JS/Lifting.dcl
View file @
2d912c78
definition
module
Sapl
.
Target
.
JS
.
Lifting
import
Sapl
.
SaplStruct
import
Data
.
Map
// Returns True if a term can be inlined, i.e. no separate statement is needed
inline
::
!
SaplTerm
->
Bool
prepareFun
::
!
FuncType
->
FuncType
prepareExpr
::
!
SaplTerm
->
SaplTerm
// First function: decide on strictness. See doStrictnessPropagation
// Map: generated functions
prepareFun
::
(!
String
!
Int
!
Int
->
Bool
)
!
FuncType
(
Map
String
FuncType
)
->
(
FuncType
,
Map
String
FuncType
)
prepareExpr
::
(!
String
!
Int
!
Int
->
Bool
)
!
SaplTerm
(
Map
String
FuncType
)
->
(
SaplTerm
,
Map
String
FuncType
)
src/Sapl/Target/JS/Lifting.icl
View file @
2d912c78
...
...
@@ -2,89 +2,146 @@ implementation module Sapl.Target.JS.Lifting
import
StdEnv
import
Sapl
.
SaplStruct
import
Data
.
Map
inline
::
!
SaplTerm
->
Bool
inline
(
SLet
_
_)
=
False
inline
(
SUpdate
_
_
_)
=
False
inline
(
SCase
cond
[(
PLit
(
LBool
true
),
case1
),(
PLit
(
LBool
false
),
case2
)])
=
inline
cond
&&
inline
case1
&&
inline
case2
inline
(
SCase
cond
[(
PLit
(
LBool
false
),
case1
),(
PLit
(
LBool
true
),
case2
)])
=
inline
cond
&&
inline
case1
&&
inline
case2
inline
(
SCase
_
_)
=
False
inline
_
=
True
prepareFun
::
!
FuncType
->
FuncType
prepareFun
(
FTFunc
name
body
args
)
=
FTFunc
name
(
prepareExpr
body
)
args
prepareFun
(
FTCAF
name
body
)
=
FTCAF
name
(
prepareExpr
body
)
prepareFun
ftype
=
ftype
::
LiftingState
=
{
varidx
::
Int
}
prepareExpr
::
!
SaplTerm
->
SaplTerm
prepareExpr
t
#
(
t
,
st
,
defs
)
=
walkTerm
t
{
varidx
=
1
}
=
case
defs
of
[]
=
t
defs
=
SLet
t
defs
walkTerm
::
!
SaplTerm
!
LiftingState
->
(!
SaplTerm
,
!
LiftingState
,
![
SaplLetDef
])
walkTerm
(
SCase
cond
patterns
)
st
|
not
(
inline
cond
)
#
(
letvar
,
st
)
=
genVar
st
#
casevar
=
SVar
(
removeTypeInfo
letvar
)
#
(
patterns
,
st
,
pdefs
)
=
walkPatterns
patterns
st
#
defs
=
[
SaplLetDef
letvar
cond
:
pdefs
]
=
case
defs
of
[]
=
(
SCase
casevar
patterns
,
st
,
[])
defs
=
(
SLet
(
SCase
casevar
patterns
)
defs
,
st
,
[])
prepareFun
::
(!
String
!
Int
!
Int
->
Bool
)
!
FuncType
(
Map
String
FuncType
)
->
(
FuncType
,
Map
String
FuncType
)
prepareFun
sf
(
FTFunc
name
body
args
)
genfuns
#
(
body
,
genfuns
)
=
prepareExpr
sf
body
genfuns
=
(
FTFunc
name
body
args
,
genfuns
)
prepareFun
sf
(
FTCAF
name
body
)
genfuns
#
(
body
,
genfuns
)
=
prepareExpr
sf
body
genfuns
=
(
FTCAF
name
body
,
genfuns
)
prepareFun
_
ftype
genfuns
=
(
ftype
,
genfuns
)
::
LiftingState
=
{
varidx
::
Int
,
genfuns
::
Map
String
FuncType
}
genUpdateFun
::
SaplTerm
->
FuncType
genUpdateFun
(
SUpdate
_
ty
updates
)
=
FTFunc
(
TypedVar
(
NormalVar
funName
0
)
NoType
)
(
SUpdate
(
SVar
(
NormalVar
"e"
0
))
ty
[(
idx
,
SVar
(
NormalVar
(
"a"
+++
toString
i
)
0
))
\\
i
<-
[
1
..
length
updates
]
&
idx
<-
map
fst
updates
])
[
TypedVar
(
NormalVar
"e"
0
)
NoType
:[
TypedVar
(
NormalVar
(
"a"
+++
toString
i
)
0
)
NoType
\\
i
<-
[
1
..
length
updates
]]]
where
genVar
{
varidx
}
=
(
TypedVar
(
StrictVar
(
"$g"
+++
toString
varidx
)
0
)
(
Type
"B"
),
{
varidx
=
varidx
+
1
})
walkTerm
c
=:(
SCase
cond
patterns
)
st
#
(
cond
,
st
,
cdefs
)
=
walkTerm
cond
st
#
(
patterns
,
st
,
pdefs
)
=
walkPatterns
patterns
st
#
defs
=
cdefs
++
pdefs
funName
=
case
ty
of
NoType
=
"update$"
+++
toString
(
mask
updates
0
)
(
Type
tn
)
=
"update$"
+++
tn
+++
"_"
+++
toString
(
mask
updates
0
)
mask
[]
bits
=
bits
mask
[(
idx
,_):
us
]
bits
=
mask
us
((
1
<<
idx
)
bitor
bits
)
prepareExpr
::
(!
String
!
Int
!
Int
->
Bool
)
!
SaplTerm
(
Map
String
FuncType
)
->
(
SaplTerm
,
Map
String
FuncType
)
prepareExpr
sf
t
genfuns
#
(
t
,
st
,
defs
)
=
walkTerm
t
False
True
{
varidx
=
1
,
genfuns
=
genfuns
}
=
case
defs
of
[]
=
(
SCase
cond
patterns
,
st
,
[])
// TODO: move to pattern
defs
=
(
SLet
(
SCase
cond
patterns
)
defs
,
st
,
[])
// TODO: bindings (insert) strict?
walkTerm
(
SLet
expr
bindings
)
st
#
(
expr
,
st
,
defs
)
=
walkTerm
expr
st
=
case
defs
of
[]
=
(
SLet
expr
bindings
,
st
,
[])
defs
=
(
SLet
expr
(
bindings
++
defs
),
st
,
[])
walkTerm
(
SSelect
expr
idx
)
st
#
(
expr
,
st
,
defs
)
=
walkTerm
expr
st
=
(
SSelect
expr
idx
,
st
,
defs
)
/*
walkTerm (SApplication sel=:(SSelect sexpr _) args) st
# (letvar, st) = genVar st
# selvar = SVar (removeTypeInfo letvar)
# (args, st, defs) = walkArgs args st
= (SApplication selvar args, st, [SaplLetDef letvar sel:defs])
[]
=
(
t
,
st
.
genfuns
)
defs
=
(
SLet
t
defs
,
st
.
genfuns
)
where
genVar {varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {varidx = varidx + 1})
*/
walkTerm
::
!
SaplTerm
!
Bool
!
Bool
!
LiftingState
->
(!
SaplTerm
,
!
LiftingState
,
![
SaplLetDef
])
walkTerm
(
SCase
cond
patterns
)
_
_
st
|
not
(
inline
cond
)
#
(
cond
,
st
,
cdefs
)
=
walkTerm
cond
True
True
st
#
(
letvar
,
st
)
=
genVar
st
#
casevar
=
SVar
(
removeTypeInfo
letvar
)
#
(
patterns
,
st
)
=
walkPatterns
patterns
st
#
defs
=
[
SaplLetDef
letvar
cond
:
cdefs
]
=
case
defs
of
[]
=
(
SCase
casevar
patterns
,
st
,
[])
defs
=
(
SLet
(
SCase
casevar
patterns
)
defs
,
st
,
[])
where
genVar
st
=:{
varidx
}
=
(
TypedVar
(
StrictVar
(
"$g"
+++
toString
varidx
)
0
)
(
Type
"B"
),
{
st
&
varidx
=
varidx
+
1
})
walkTerm
c
=:(
SCase
cond
patterns
)
doNotLift
_
st
#
(
cond
,
st
,
cdefs
)
=
walkTerm
cond
False
True
st
#
(
patterns
,
st
)
=
walkPatterns
patterns
st
#
defs
=
cdefs
=
case
defs
of
[]
=
(
SCase
cond
patterns
,
st
,
[])
// TODO: move to pattern?
defs
=
(
SLet
(
SCase
cond
patterns
)
defs
,
st
,
[])
walkTerm
(
SLet
expr
bindings
)
doNotLift
_
st
#
(
expr
,
st
,
edefs
)
=
walkTerm
expr
False
True
st
#
(
bindings
,
st
,
bdefs
)
=
walkBindings
bindings
st
#
defs
=
edefs
++
bdefs
=
case
defs
of
[]
=
(
SLet
expr
(
bindings
++
defs
),
st
,
[])
defs
=
(
SLet
expr
(
bindings
++
defs
),
st
,
[])
walkTerm
(
SSelect
expr
ty
idx
)
doNotLift
strictPosition
st
#
(
expr
,
st
,
defs
)
=
walkTerm
expr
False
strictPosition
st
=
(
SSelect
expr
ty
idx
,
st
,
defs
)
walkTerm
(
SUpdate
expr
ty
updates
)
False
True
st
#
(
letvar
,
st
)
=
genVar
st
#
updvar
=
SVar
(
removeTypeInfo
letvar
)
#
(
updates
,
st
,
udefs
)
=
walkUpdates
updates
st
#
(
expr
,
st
,
edefs
)
=
walkTerm
expr
False
True
st
=
(
updvar
,
st
,
[
SaplLetDef
letvar
(
SUpdate
expr
ty
updates
):
edefs
++
udefs
])
where
genVar
st
=:{
varidx
}
=
(
TypedVar
(
StrictVar
(
"$g"
+++
toString
varidx
)
0
)
NoType
,
{
st
&
varidx
=
varidx
+
1
})
walkTerm
(
SUpdate
expr
ty
updates
)
False
False
st
#
(
expr
,
st
,
edefs
)
=
walkTerm
expr
False
False
st
#
(
updates
,
st
,
udefs
)
=
walkUpdates
updates
st
// Generate new fun and lift it in the same time
#
(
genfun
,
_)
=
prepareFun
sf
(
genUpdateFun
(
SUpdate
expr
ty
updates
))
newMap
#
funname
=
extractName
genfun
=
(
SApplication
(
SVar
funname
)
[
expr
:
map
snd
updates
],
{
st
&
genfuns
=
put
(
unpackVar
funname
)
genfun
st
.
genfuns
},
edefs
++
udefs
)
where
extractName
(
FTFunc
(
TypedVar
name
_)
_
_)
=
name
walkTerm
(
SUpdate
expr
ty
updates
)
_
strictPosition
st
#
(
expr
,
st
,
edefs
)
=
walkTerm
expr
False
strictPosition
st
#
(
updates
,
st
,
udefs
)
=
walkUpdates
updates
st
=
(
SUpdate
expr
ty
updates
,
st
,
edefs
++
udefs
)
walkTerm
(
SApplication
v
=:(
SVar
name
)
args
)
doNotLift
strictPosition
st
#
(
args
,
st
,
defs
)
=
walkArgs
[
sf
(
unpackVar
name
)
(
length
args
)
i
\\
i
<-
[
0
..]]
args
st
=
(
SApplication
v
args
,
st
,
defs
)
walkTerm
(
SApplication
name
args
)
doNotLift
strictPosition
st
#
(
args
,
st
,
defs
)
=
walkArgs
(
repeat
False
)
args
st
=
(
SApplication
name
args
,
st
,
defs
)
walkTerm
t
_
_
st
=
(
t
,
st
,
[])
walkArgs
_
[]
st
=
([],
st
,
[])
walkArgs
[
isStrict
:
si
]
[
t
:
ts
]
st
#
(
t
,
st
,
def
)
=
walkTerm
t
False
isStrict
st
#
(
ts
,
st
,
defs
)
=
walkArgs
si
ts
st
=
([
t
:
ts
],
st
,
def
++
defs
)
walkPatterns
[]
st
=
([],
st
)
walkPatterns
[(
p
,
t
):
ps
]
st
#
(
t
,
st
,
defs
)
=
walkTerm
t
False
True
st
#
t
=
case
defs
of
[]
=
t
defs
=
SLet
t
defs
#
(
ps
,
st
)
=
walkPatterns
ps
st
=
([(
p
,
t
):
ps
],
st
)
walkBindings
[]
st
=
([],
st
,
[])
walkBindings
[
SaplLetDef
var
expr
:
bs
]
st
#
(
expr
,
st
,
def
)
=
walkTerm
expr
True
(
isStrictVar
var
)
st
#
(
bs
,
st
,
defs
)
=
walkBindings
bs
st
=
([
SaplLetDef
var
expr
:
bs
],
st
,
def
++
defs
)
walkTerm
(
SApplication
name
args
)
st
#
(
args
,
st
,
defs
)
=
walkArgs
args
st
=
(
SApplication
name
args
,
st
,
defs
)
walkUpdates
[]
st
=
([],
st
,
[])
walkUpdates
[(
idx
,
expr
):
us
]
st