Commit 8de10300 authored by Jurriën Stutterheim's avatar Jurriën Stutterheim

Merge branch 'hierarchical' of gitlab.science.ru.nl:clean-and-itasks/clean-sapl into hierarchical

parents 9eee0957 4b7dc029
......@@ -2,4 +2,9 @@ definition module Sapl.Optimization.StrictnessPropagation
import Sapl.SaplParser, Sapl.Target.Flavour
doStrictnessPropagation :: !ParserState !Flavour ![FuncType] -> (![FuncType], !ParserState)
:: IsStrictArgFun :== !ParserState !String !Int !Int -> Bool
// strict argument checker for Flavour file
isStrictArgFlavour :: !Flavour !ParserState !String !Int !Int -> Bool
doStrictnessPropagation :: !ParserState !IsStrictArgFun ![FuncType] -> (![FuncType], !ParserState)
......@@ -7,7 +7,8 @@ from Data.Set import :: Set, newSet, fromList, member, insert, delete, union, un
from Data.Map import get, put
import Data.Maybe
isStrictArg {ps_constructors, ps_functions} {builtInFunctions, inlineFunctions} n nr_args i
isStrictArgFlavour :: !Flavour !ParserState !String !Int !Int -> Bool
isStrictArgFlavour {builtInFunctions, inlineFunctions} {ps_constructors, ps_functions} n nr_args i
= checkCons
where
checkCons = case get n ps_constructors of
......@@ -22,19 +23,19 @@ where
(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
doStrictnessPropagation :: !ParserState !IsStrictArgFun ![FuncType] -> (![FuncType], !ParserState)
doStrictnessPropagation ps isStrictArg funs
# (nfs, nps) = foldl (\(nfs,ps) f -> let (nf, nps) = propFunc ps isStrictArg 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)
propFunc :: !ParserState !IsStrictArgFun !FuncType -> (!FuncType, !ParserState)
propFunc ps=:{ps_functions} isStrictArg (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)
(ds, nbody) = (propBody ps isStrictArg newSet body)
nargs = map addStrictness args
addStrictness var=:(TypedVar (StrictVar _ _) _) = var
......@@ -42,8 +43,8 @@ where
propFunc ps _ f = (f, ps)
propBody :: !ParserState !Flavour !(Set String) !SaplTerm -> (!Set String, !SaplTerm)
propBody ps flavour sd body = walk sd body
propBody :: !ParserState !IsStrictArgFun !(Set String) !SaplTerm -> (!Set String, !SaplTerm)
propBody ps isStrictArg sd body = walk sd body
where
walk sd t=:(SVar var) = (insert (unpackVar var) sd, t)
......@@ -59,7 +60,7 @@ where
where
varName = unpackVar var
nr_args = length args
checkArg (arg, i) = isStrictArg ps flavour varName nr_args i
checkArg (arg, i) = isStrictArg ps varName nr_args i
strictArgs = map fst (filter checkArg (zip2 args [0..]))
// We can skip the new expr, cannot contain let definitions...
......
......@@ -720,7 +720,7 @@ generateJS f tramp saplsrc mbPst
# pts = tokensWithPositions saplsrc
= case parse pts of
Ok (funcs, s) # newpst = mergeParserStates s mbPst
# (funcs, newpst) = if (isSet f "enableStrictnessPropagation") (doStrictnessPropagation newpst f funcs) (funcs, newpst)
# (funcs, newpst) = if (isSet f "enableStrictnessPropagation") (doStrictnessPropagation newpst (isStrictArgFlavour f) funcs) (funcs, newpst)
# state = newState f tramp newpst
# a = newAppender <++ "\"use strict\";"
# a = a <++ "/*Trampoline: "
......
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