Commit c0acab9a authored by Laszlo Domoszlai's avatar Laszlo Domoszlai
Browse files

check for tail recursion (not exploited as now)

parent 4a9b1363
......@@ -482,6 +482,8 @@ Code* parseTerm(char **ptr) {
return (Code*) parseVar(ptr, NULL);
case 'A': // Static application
return (Code*) parseApp(ptr, false);
case 'T': // Tail recursive application
return (Code*) parseApp(ptr, false);
case 'D': // Dynamic application
return (Code*) parseApp(ptr, true);
case 'S': // Select
......
......@@ -3,7 +3,7 @@ module precompiler
import Sapl.SaplParser
import Sapl.SaplTokenizer
import StdList, StdFile, System.File
import StdBool, StdList, StdFile, StdDebug
import Text.StringAppender, Text
import Data.Map
......@@ -18,9 +18,11 @@ import System.File
:: Context = { vars :: Map String VarType
, localcount :: Int
, inspine :: Bool
, currentFun :: String
}
newContext = {vars = newMap, localcount = 0}
newContext = {vars = newMap, localcount = 0, inspine = False, currentFun = ""}
registerArgs vars idx [] = vars
registerArgs vars idx [v:vs] = registerArgs (put (unpackVar v) (Local idx (isStrictVar v)) vars) (idx + 1) vs
......@@ -33,16 +35,19 @@ calcStrictness [StrictVar _ _:vs] idx = (1 << idx) + calcStrictness vs (idx + 1)
calcStrictness [NormalVar _ _:vs] idx = calcStrictness vs (idx + 1)
sFunc ctx (FTFunc name body params) a
# ctx = {ctx & vars = registerArgs ctx.vars 0 params, localcount = length params}
# ctx = {ctx & vars = registerArgs ctx.vars 0 params, localcount = length params, inspine = True, currentFun = (unpackVar name)}
= a <++ "F" <++ sText (unpackVar name) <++ sNum (length params) <++ sNum (calcStrictness params 0) <++ sTerm ctx body
sFunc ctx (FTCAF name body) a
# ctx = {ctx & inspine = False, currentFun = (unpackVar name)}
= a <++ "C" <++ sText (unpackVar name) <++ sTerm ctx body
sFunc ctx (FTRecord name fields) a
# ctx = {ctx & inspine = False, currentFun = (unpackVar name)}
= a <++ "R" <++ sText (unpackVar name) <++ sNum (length fields) <++ sNum (calcStrictness fields 0) <++ sList0 sText (map unpackVar fields)
sFunc ctx (FTADT typeName cs) a
# ctx = {ctx & inspine = False, currentFun = (unpackVar typeName)}
= a <++ "A" <++ sList sCon cs
where
sCon (SaplConstructor name _ params) a
......@@ -58,10 +63,17 @@ sText text a = a <++ sNum (textSize text) <++ text
sTerm ctx (SLit lit) a = a <++ "L" <++ lit
sTerm ctx (SVar var) a = a <++ sVarApp ctx var
sTerm ctx (SApplication var terms) a = a <++ if (isLocalVar ctx var) "D" "A" <++ sList (sTerm ctx) terms <++ sVar ctx var
sTerm ctx (SSelect expr cs) a = a <++ "S" <++ sTerm ctx expr <++ sList (sSelectCase ctx) cs
sTerm ctx (SIf cond texpr fexpr) a = a <++ "I" <++ sTerm ctx cond <++ sTerm ctx texpr <++ sTerm ctx fexpr
sTerm ctx (SApplication var terms) a = a <++ appType ctx var <++ sList (sTerm {ctx & inspine = False}) terms <++ sVar ctx var
sTerm ctx (SSelect expr cs) a = a <++ "S" <++ sTerm {ctx & inspine = False} expr <++ sList (sSelectCase ctx) cs
sTerm ctx (SIf cond texpr fexpr) a = a <++ "I" <++ sTerm {ctx & inspine = False} cond <++ sTerm ctx texpr <++ sTerm ctx fexpr
isLocalVar ctx var = member (unpackVar var) ctx.vars
appType ctx var | isLocalVar ctx var
= "D"
appType {inspine, currentFun} var = if (inspine && unpackVar var == currentFun) "T" "A" // T: tail recursive
sSelectCase ctx (PCons varName params, expr) a
# ctx = {ctx & vars = registerLocals ctx.vars ctx.localcount params, localcount = ctx.localcount + length params}
= a <++ "C" <++ sText varName <++ sTerm ctx expr
......@@ -70,8 +82,6 @@ sSelectCase ctx (PLit lit, expr) a
sSelectCase ctx (PDefault, expr) a
= a <++ "D" <++ sTerm ctx expr
isLocalVar ctx var = member (unpackVar var) ctx.vars
sVar ctx var a
= case get varName ctx.vars of
(Just (Local i True)) = a <++ "S" <++ sNum i
......
......@@ -130,6 +130,20 @@ OtherModules
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
Module
Name: StdDebug
Dir: {Application}\Libraries\StdEnv
Compiler
NeverMemoryProfile: False
NeverTimeProfile: False
StrictnessAnalysis: True
ListTypes: StrictExportTypes
ListAttributes: True
Warnings: True
Verbose: True
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
Module
Name: StdEnum
Dir: {Application}\Libraries\StdEnv
......
Supports Markdown
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