Commit a10a0f19 authored by László Domoszlai's avatar László Domoszlai

small optimization with selectors

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@622 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent e1453b63
...@@ -19,6 +19,7 @@ import Data.Maybe ...@@ -19,6 +19,7 @@ import Data.Maybe
| SVar SaplVar | SVar SaplVar
| SApplication SaplVar [SaplTerm] | SApplication SaplVar [SaplTerm]
| SIf SaplTerm SaplTerm SaplTerm | SIf SaplTerm SaplTerm SaplTerm
| SSelector SaplTerm
| SSelect SaplTerm [(SaplPattern, SaplTerm)] | SSelect SaplTerm [(SaplPattern, SaplTerm)]
| SLet SaplTerm [SaplLetDef] | SLet SaplTerm [SaplLetDef]
| SAbortBody | SAbortBody
......
...@@ -9,9 +9,11 @@ implementation module Sapl.Target.JS.CodeGeneratorJS ...@@ -9,9 +9,11 @@ implementation module Sapl.Target.JS.CodeGeneratorJS
*/ */
import StdEnv, Data.Maybe, Data.Void, Text.StringAppender, Data.Map, Sapl.FastString import StdEnv, Data.Maybe, Data.Void, Text.StringAppender, Data.Map, Sapl.FastString
import qualified Data.List as DL
import Text.Unicode.Encodings.JS import Text.Unicode.Encodings.JS
import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimization.StrictnessPropagation import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimization.StrictnessPropagation
import Sapl.Transform.Let import Sapl.Transform.Let
import Sapl.Transform.AddSelectors
from Data.List import elem_by, partition from Data.List import elem_by, partition
...@@ -110,7 +112,7 @@ isTailRecursive var (SLet body _) = isTailRecursive var body ...@@ -110,7 +112,7 @@ isTailRecursive var (SLet body _) = isTailRecursive var body
isTailRecursive _ _ = False isTailRecursive _ _ = False
funcCoder :: !FuncType !CoderState !StringAppender -> StringAppender funcCoder :: !FuncType !CoderState !StringAppender -> StringAppender
funcCoder (FTFunc name body args) s a = normalFunc name body args s a 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 funcCoder (FTMacro name body args) s a = normalFunc name body args s a
funcCoder (FTCAF name body) s a = encodeCAF name body s a funcCoder (FTCAF name body) s a = encodeCAF name body s a
funcCoder (FTADT name args) s a = foldl (\a t = termCoder t s a) a args funcCoder (FTADT name args) s a = foldl (\a t = termCoder t s a) a args
...@@ -579,6 +581,11 @@ where ...@@ -579,6 +581,11 @@ where
termCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender termCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
termCoder t=:(SVar var) s a = termCoder var s a termCoder t=:(SVar var) s a = termCoder var s a
termCoder t=:(SSelector (SSelect expr [(PCons _ vs, SVar x)])) s a
# (idx, _) = foldl (\(idx, cnt) v -> if (eqVarByName x v) (cnt, cnt) (idx, cnt + 1)) (0, 0) vs
= a <++ "Sapl.feval(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "])"
termCoder t=:(SSelector x) s a = termCoder x s a
termCoder t=:(SSelect expr patterns) s a | any (isConsPattern o fst) patterns termCoder t=:(SSelect expr patterns) s a | any (isConsPattern o fst) patterns
# a = a <++ "var ys=" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ ";" # a = a <++ "var ys=" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ ";"
= if (containsUnsafeSelect s t) (unsafe a) (safe a) = if (containsUnsafeSelect s t) (unsafe a) (safe a)
......
definition module Sapl.Transform.AddSelectors
from Sapl.SaplStruct import :: SaplTerm
class addSelectors t :: !t -> t
instance addSelectors SaplTerm
implementation module Sapl.Transform.AddSelectors
import Sapl.SaplStruct
import StdBool, StdList
instance addSelectors SaplTerm where
addSelectors (SApplication v ts) = SApplication v (map addSelectors ts)
addSelectors (SIf c t e) = SIf (addSelectors c) (addSelectors t) (addSelectors e)
addSelectors st=:(SSelect t ps=:[(PCons _ vs, SVar x)])
# t` = addSelectors t
| foldr (\v acc -> acc || eqVarByName v x) False vs = SSelector (SSelect t` ps)
| otherwise = SSelect t` ps
addSelectors (SLet t lds) = SLet (addSelectors t) (map addSelectors lds)
addSelectors st = st
instance addSelectors SaplLetDef where
addSelectors (SaplLetDef v t) = SaplLetDef v (addSelectors t)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment