We planned to upgrade GitLab and Mattermost to the latest version this Friday morning (early). You may experience some downtime!

Commit 7ee35566 authored by László Domoszlai's avatar László Domoszlai

add strictness propagation

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@457 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent 29cd5778
definition module Sapl.Optimization.StrictnessPropagation
import Sapl.SaplParser, Sapl.Target.Flavour
doStrictnessPropagation :: !ParserState !Flavour ![FuncType] -> (![FuncType], !ParserState)
implementation module Sapl.Optimization.StrictnessPropagation
import StdEnum, StdArray, StdTuple, StdBool
from StdList import map, foldl, !!, zip2, unzip, filter, reverse, instance length []
import Sapl.SaplParser, Sapl.Target.Flavour
from Data.Set import :: Set, newSet, fromList, member, insert, delete, union, unions, intersection, intersections, difference
from Data.Map import get, put
import Data.Maybe
isStrictArg {ps_constructors, ps_functions} {builtInFunctions, inlineFunctions} n nr_args i
= checkCons
where
checkCons = case get n ps_constructors of
(Just cons) = if (nr_args < cons.nr_args || i >= cons.nr_args) False (isStrictVar (cons.args !! i))
= checkFun
checkFun = case get n ps_functions of
(Just args) = let largs = length args in if (nr_args < largs || i >= largs) False (isStrictVar (args !! i))
= checkInline
checkInline = case get n inlineFunctions of
(Just def) = if (nr_args < def.arity || i >= def.arity) False (def.strictness.[i] == '1')
= False
doStrictnessPropagation :: !ParserState !Flavour ![FuncType] -> (![FuncType], !ParserState)
doStrictnessPropagation ps flavour funs
# (nfs, nps) = foldl (\(nfs,ps) f -> let (nf, nps) = propFunc ps flavour f in ([nf:nfs], nps)) ([], ps) funs
= (reverse nfs, nps)
// TODO: if strictness is given to the arguments the whole propogation stuff
// should be recomputed again and again until a fixpoint...
// Expect: if the functions are in the good order which is the case if the code is linked
propFunc :: !ParserState !Flavour !FuncType -> (!FuncType, !ParserState)
propFunc ps=:{ps_functions} flavour (FTFunc name body args)
= (FTFunc name nbody nargs, {ps & ps_functions = put (unpackVar name) nargs ps_functions})
where
(ds, nbody) = (propBody ps flavour newSet body)
nargs = map addStrictness args
addStrictness var=:(StrictVar _ _) = var
addStrictness var=:(NormalVar vn _) = if (member vn ds) (toStrictVar var) var
propFunc ps _ f = (f, ps)
propBody :: !ParserState !Flavour !(Set String) !SaplTerm -> (!Set String, !SaplTerm)
propBody ps flavour sd body = walk sd body
where
walk sd t=:(SVar var) = (insert (unpackVar var) sd, t)
walk sd t=:(SApplication var args)
// We can skip the new args, cannot contain let definitions...
# nsds = map fst (map (walk newSet) strictArgs)
= (unions [sd:nsds], t)
where
varName = unpackVar var
nr_args = length args
checkArg (arg, i) = isStrictArg ps flavour varName nr_args i
strictArgs = map fst (filter checkArg (zip2 args [0..]))
walk sd (SIf c l r)
# (sdl, nl) = walk newSet l
# (sdr, nr) = walk newSet r
# (sdc, nc) = walk sd c
= (union sdc (intersection sdl sdr), SIf nc nl nr)
walk sd (SSelect p cases)
# (sdp, np) = walk sd p
# (sdcs, ncases) = unzip (map walkcase cases)
= (union sdp (intersections sdcs), SSelect np ncases)
where
walkcase (p, c)
# (sd, nc) = walk newSet c
= (difference sd (patternvars p), (p, nc))
patternvars (PCons _ vars) = fromList (map unpackVar vars)
patternvars _ = newSet
// It is supposed that bindings are topologically sorted
walk sd (SLet body bnds)
# (sdb, nbody) = walk newSet body
# (sdl, nbnds) = wbnds sdb (reverse bnds) [] // reverse is important
= (union sd sdl, SLet nbody nbnds)
where
wbnds sd [] nbnds = (sd, nbnds)
wbnds sd [bnd:bnds] nbnds
# nbnd = if (member vn sd) (toStrictBind bnd) bnd
# nsd = walkbnd sd nbnd
= wbnds nsd bnds [nbnd:nbnds]
where
vn = unpackVar (unpackBindVar bnd)
// Delete itself, it dosn't need any more
walkbnd sd (SaplLetDef (StrictVar vn _) body) = delete vn (fst (walk sd body)) // skip new body, it cannot be a let definition
walkbnd sd (SaplLetDef (NormalVar vn _) body) = delete vn sd
walk sd t = (sd, t)
\ No newline at end of file
......@@ -48,6 +48,7 @@ toStrictVar :: !SaplVar -> SaplVar
unpackVar :: !SaplVar -> String
unpackBindVar :: !SaplLetDef -> SaplVar
unpackConsName :: !SaplPattern -> Maybe String
toStrictBind :: !SaplLetDef -> SaplLetDef
isConsPattern :: !SaplPattern -> Bool
isDefaultPattern :: !SaplPattern -> Bool
......
......@@ -52,6 +52,9 @@ unpackConsName :: !SaplPattern -> Maybe String
unpackConsName (PCons cons _) = Just cons
unpackConsName _ = Nothing
toStrictBind :: !SaplLetDef -> SaplLetDef
toStrictBind (SaplLetDef var body) = SaplLetDef (toStrictVar var) body
isConsPattern :: !SaplPattern -> Bool
isConsPattern (PCons _ _) = True
isConsPattern _ = False
......
......@@ -10,7 +10,7 @@ implementation module Sapl.Target.JS.CodeGeneratorJS
import StdEnv, Data.Maybe, Data.Void, Text.StringAppender, Data.Map, Sapl.FastString
import Text.Unicode.Encodings.JS
import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour
import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimization.StrictnessPropagation
import Sapl.Transform.Let
from Data.List import elem_by, partition
......@@ -678,6 +678,7 @@ generateJS f tramp saplsrc mbPst
# pts = tokensWithPositions saplsrc
= case parse pts of
Ok (funcs, s) # newpst = mergeParserStates s mbPst
# (funcs, newpst) = doStrictnessPropagation newpst f funcs
# state = newState f tramp newpst
# a = newAppender <++ "/*Trampoline: "
# a = if tramp (a <++ "ON") (a <++ "OFF")
......
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