Lifting.icl 5.57 KB
Newer Older
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
1
2
3
4
implementation module Sapl.Target.JS.Lifting

import StdEnv
import Sapl.SaplStruct
5
6
from Data.Map import :: Map
import qualified Data.Map as DM
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
7
8
9

inline :: !SaplTerm -> Bool
inline (SLet _ _) = False
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
10
inline (SUpdate _ _ _) = False
11
12
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
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
13
14
15
inline (SCase _ _) = False
inline _ = True

16
prepareFun :: (String Int Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
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]]]
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
33
where
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
34
35
36
37
38
39
40
	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)
	
41
prepareExpr :: (String Int Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
42
43
prepareExpr sf t genfuns
	# (t, st, defs) = walkTerm t False True {varidx = 1, genfuns = genfuns} 
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
44
	= case defs of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
45
46
		[] = (t, st.genfuns)
		defs = (SLet t defs, st.genfuns)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
47
where
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
	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})

90
91
	walkTerm (SUpdate expr ty updates) doNotLift False st
		# (expr, st, edefs) = walkTerm expr doNotLift False st 
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
92
93
		# (updates, st, udefs) = walkUpdates updates st
		// Generate new fun and lift it in the same time
94
		# (genfun, _) = prepareFun sf (genUpdateFun (SUpdate expr ty updates)) 'DM'.newMap 
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
95
96
		# funname = extractName genfun
		=  (SApplication (SVar funname) [expr:map snd updates], 
97
					{st & genfuns = 'DM'.put (unpackVar funname) genfun st.genfuns}, edefs ++ udefs)  
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
98
99
100
	where
		extractName (FTFunc (TypedVar name _) _ _) = name

101
102
103
	// TODO: is it a real option?
	walkTerm (SUpdate expr ty updates) True True st
		# (expr, st, edefs) = walkTerm expr False True st 
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
		# (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)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
137

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
138
139
140
141
142
	walkUpdates [] st = ([], st, [])
	walkUpdates [(idx,expr):us] st 
		# (expr, st, def) = walkTerm expr True False st
		# (us, st, defs) = walkUpdates us st
		= ([(idx, expr):us], st, def ++ defs)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
143
144


Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
145
		
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
146
147
148
149