Skip to content
GitLab
Menu
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
clean-sapl
Commits
2d912c78
Commit
2d912c78
authored
Apr 26, 2016
by
Laszlo Domoszlai
Browse files
"update" syntax
parent
8de10300
Changes
10
Hide whitespace changes
Inline
Side-by-side
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
Lambd
a
=
"
\\
"
toString
TColon
=
"
,
"
toString
T
Comm
a
=
"
,
"
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
,