Lifting.icl 5.52 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
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
5
import Data.Map
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
6 7 8

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

15
prepareFun :: (String Int Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
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
32
where
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
33 34 35 36 37 38 39
	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)
	
40
prepareExpr :: (String Int Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
41 42
prepareExpr sf t genfuns
	# (t, st, defs) = walkTerm t False True {varidx = 1, genfuns = genfuns} 
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
43
	= case defs of
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
44 45
		[] = (t, st.genfuns)
		defs = (SLet t defs, st.genfuns)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
46
where
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
47 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
	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})

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

100 101 102
	// 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
103 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
		# (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
136

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
137 138 139 140 141
	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
142 143


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