CodeGeneratorJS.icl 34.2 KB
Newer Older
1
implementation module Sapl.Target.JS.CodeGeneratorJS
2 3 4

/* TODO:
 *
5 6 7
 * - Cyclical let definitions are not handled correctly:
 *		1. strictness should be removed from the definition which references the later one
 *		2. tail recursion optimization shouldn't be used in the function which has cyclical let definitions (scoping problem)
8
 *
9
 */
10

11
import StdEnv, Data.Maybe, Data.Void, Text.StringAppender, Sapl.FastString
12
import qualified Data.List as DL
13
import qualified Data.Map as DM
14
import Text.Unicode.Encodings.JS
15
import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimization.StrictnessPropagation
16
import Sapl.Transform.Let
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
17
import Sapl.Target.JS.Lifting
18
import Sapl.Transform.AddSelectors
19
import Sapl.Transform.TailRecursion
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
20
import StdDebug
21

22 23
from Data.List import elem_by, partition

24 25
:: CoderState = { cs_inbody 		:: !Maybe SaplTypedVar     // The body of the function which is being generated (not signature)
				, cs_intrfunc		:: !Maybe SaplTypedVar     // The name of the currently generated function if it is tail recursive
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
26
				, cs_inletbind		:: !Maybe SaplTypedVar     // The name of the let binding we are in
27
				, cs_futuredefs		:: ![SaplTypedVar]     	   // for finding out about let-rec and let bindings defined later 
28
				, cs_incaseexpr		:: !Bool
29
				, cs_current_vars 	:: ![SaplTypedVar]		 		
30
				, cs_constructors	:: !Map String ConstructorDef
31
				, cs_functions		:: !Map String [SaplTypedVar]
32 33 34 35 36
				, cs_CAFs			:: !Map String Void				
				, cs_builtins		:: !Map String (String, Int)
				, cs_inlinefuncs	:: !Map String InlineFunDef
				, cs_trampoline     :: !Bool
				, cs_prefix         :: !String
37 38 39 40
		      	}

newState :: !Flavour !Bool !ParserState -> CoderState
newState f tramp p =
41
			 { cs_inbody 		= Nothing
42
			 , cs_intrfunc 		= Nothing
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
43
			 , cs_inletbind		= Nothing
44
			 , cs_futuredefs	= []
45
			 , cs_incaseexpr 	= False
46 47 48 49 50 51 52 53 54 55
			 , cs_current_vars 	= []
			 , cs_constructors 	= p.ps_constructors
			 , cs_functions		= p.ps_functions
			 , cs_CAFs			= p.ps_CAFs
			 , cs_builtins		= f.builtInFunctions
			 , cs_inlinefuncs	= f.inlineFunctions
			 , cs_trampoline    = tramp
			 , cs_prefix        = f.fun_prefix
			 }

56
pushArgs :: !CoderState ![SaplTypedVar] -> CoderState
57 58 59
pushArgs s [t:ts] = pushArgs {s & cs_current_vars = [t:s.cs_current_vars]} ts
pushArgs s [] = s

60 61 62 63 64 65 66
condForce :: !Bool !a !StringAppender -> StringAppender | Appendable a
condForce True e a = a <++ "Sapl.feval(" <++ e <++ ")"
condForce False e a = a <++ e

force e a = condForce True e a
forceApp e a = a <++ "Sapl.fapp(" <++ e <++ ")"

67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
// Escape identifier, except the "$eval" part if it ends like that		
escapeName :: !String !String !StringAppender -> StringAppender
escapeName prefix name a = a <++ prefix <++ toString (urlEncode` (fromString name))
where 
	// A slightly modified URL encoding scheme
	urlEncode` :: ![Char] -> [Char]
	urlEncode` []						= []
	urlEncode` e=:['$eval']				= e		
	urlEncode` [x:xs] 
	| isAlphanum x						= [x  : urlEncode` xs]
	| otherwise							= urlEncodeChar x ++ urlEncode` xs
	where
		urlEncodeChar '_'				= ['_']
		urlEncodeChar '.'				= ['_']		
		urlEncodeChar ' '				= ['+']
82
		urlEncodeChar '$'				= ['$']		
83 84 85 86 87 88 89 90 91 92 93 94 95
		urlEncodeChar x					= ['$', c1 ,c2]
		
		(c1,c2)							= charToHex x

		charToHex :: !Char -> (!Char, !Char)
		charToHex c						= (toChar (digitToHex (i >> 4)), toChar (digitToHex (i bitand 15)))
		where
		        i						= toInt c
		        digitToHex :: !Int -> Int
		        digitToHex d
		                | d <= 9		= d + toInt '0'
		                | otherwise		= d + toInt 'A' - 10
				   
96
callWrapper :: !SaplTerm !CoderState !StringAppender -> StringAppender
97 98 99
callWrapper t s a
	| not (inline t)
		= termCoder t s a		
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
100 101
	| isJust s.cs_inletbind
		= a <++ "var " <++ termCoder (fromJust s.cs_inletbind) {s & cs_futuredefs = []} <++ "=" <++ forceTermCoder t s <++ ";"
102
	| isJust s.cs_intrfunc && isTailRecursive (fromJust s.cs_intrfunc) t
103 104 105 106 107
		= forceTermCoder t s a
	| s.cs_trampoline
		= a <++ "return " <++ trampolineCoder t s <++ ";" 	
		= a <++ "return " <++ forceTermCoder t s <++ ";" 

108
isTailRecursive :: !SaplTypedVar !SaplTerm -> Bool
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
109 110
isTailRecursive var (SCase _ patterns) = any (isTailRecursive var o snd) patterns
isTailRecursive var (SApplication (SVar avar) _) = unpackVar var == unpackVar avar
111
isTailRecursive var (SLet body _) = isTailRecursive var body
112 113
isTailRecursive _ _ = False

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
114 115 116 117 118 119 120 121 122 123 124
strictnessMap :: !SaplType !CoderState -> Int
strictnessMap NoType _ = 0
strictnessMap (Type cons) {cs_constructors} 
	= case get cons cs_constructors of
		Nothing = 0
		(Just {args}) = toInt args 0
where
	toInt [] _ = 0
	toInt [TypedVar (StrictVar _ _) _:as] i = (toInt as (i+1)) bitor (2 << i)
	toInt [TypedVar (NormalVar _ _) _:as] i = toInt as (i+1)	

125
funcCoder :: !FuncType !CoderState !StringAppender -> StringAppender
126
funcCoder (FTFunc name body args) s a = normalFunc name (addSelectors body) args s a
127
funcCoder (FTMacro name body args) s a = normalFunc name body args s a
128
funcCoder (FTCAF name body) s a = encodeCAF name body s a
129 130
funcCoder (FTADT name args) s a = foldl (\a t = termCoder t s a) a args
funcCoder (FTRecord name args) s a 
László Domoszlai's avatar
László Domoszlai committed
131
	# a = a <++ constructorCoder name 0 args s
132
	= a <++ termCoder name s <++ ".$f=[" <++ recordFieldCoder args <++ "];"
133

134
// Only real constants can be safely encoded as a simple variable...
135
encodeCAF :: !SaplTypedVar !SaplTerm !CoderState !StringAppender -> StringAppender
136
encodeCAF name body=:(SLit _) s a
László Domoszlai's avatar
László Domoszlai committed
137
	# a = a <++ "var " <++ termCoder name s <++ " = "
138 139 140 141 142 143 144 145 146

	# s = {s & cs_inbody = Just name
			 , cs_current_vars = []
			 , cs_intrfunc = Nothing
			 }

	# a = termCoder body s a
	= a <++ ";"  

László Domoszlai's avatar
László Domoszlai committed
147 148 149 150 151 152 153 154 155 156 157 158 159 160
// ... everything else must be wrapped into an anonymous function to avoid 
// undefined references (because of variables and functions declared later)
encodeCAF name body s a
	# a = a <++ "var " <++ termCoder name s <++ " = [function (){"

	# s = {s & cs_inbody = Just name
			 , cs_current_vars = []
			 , cs_intrfunc = Nothing
			 }

	# a = a <++ callWrapper body s 

	= a <++ "},[]];";

161
normalFunc :: !SaplTypedVar !SaplTerm ![SaplTypedVar] !CoderState !StringAppender -> StringAppender
162 163
normalFunc name body args s a
	// Generate $eval function if any of its arguments is annotated as strict	
164 165
	# a = if (any isStrictVar args) 
				(makeStrictClosure (unpackVar name) args s a) a
166 167 168 169
				
	// Generate function signature			
	# a = a <++ "function " <++ termCoder name s
			<++ "(" <++ termArrayCoder args "," s <++ "){"
170
	
171
	// Update coder state with the new local arguments, ...
172
	# s = {s & cs_inbody = Just name
173 174 175 176 177 178 179 180 181
			 , cs_current_vars = args
			 , cs_intrfunc = if (isTailRecursive name body) (Just name) Nothing}

	// Generate body (in a while(1) if the function is tail recursive)				
	# a = if (isJust s.cs_intrfunc) (a <++ "while(1){") a
	# a = callWrapper body s a
	# a = if (isJust s.cs_intrfunc) (a <++ "}") a
	= a <++ "};"  

László Domoszlai's avatar
László Domoszlai committed
182 183 184 185 186 187 188 189
// The (i-1) is to be compatible with the original compiler written in JavaScript
makeStrictClosure name args s a
	= a <++ "function " 
		<++ escapeName s.cs_prefix name <++ "$eval("
		<++ joinList "," ["a"+++toString (i-1) \\ i <- [1..length args]]
		<++ "){return " <++ escapeName s.cs_prefix name <++ "("
		<++ (\a = fst (foldl strictsep (a,1) args))
		<++ ");};"
190
where
László Domoszlai's avatar
László Domoszlai committed
191
	strictsep (a,i) arg
192
		# a = condForce (isStrictVar arg) (\a -> a <++ "a" <++ toString (i-1)) a
László Domoszlai's avatar
László Domoszlai committed
193 194 195
		| i < (length args)
			= (a <++ ",", i+1)
			= (a, i)
196

197
make_app_args :: !SaplVar ![SaplTerm] !CoderState !StringAppender -> StringAppender
198
make_app_args func args s a 
199
	= case 'DM'.get (unpackVar func) s.cs_functions of
200
		Just func_args = a <++ maa_ func_args args 0 s
201
					   = a <++ maa_ [] args 0 s 
202 203
where
	// fargs: formal, aargs: actual	
204
	maa_ [TypedVar (StrictVar _ _) _:fargs] [aa:aargs] i s a 
205 206 207 208 209 210 211 212 213 214
		# a = if (i>0) (a <++ ",") a
		= a <++ forceTermCoder aa s <++ maa_ fargs aargs (i+1) s 
	maa_ [_:fargs] [aa:aargs] i s a 
		# a = if (i>0) (a <++ ",") a		
		= a <++ termCoder aa s <++ maa_ fargs aargs (i+1) s 
	maa_ [] [aa:aargs] i s a 
		# a = if (i>0) (a <++ ",") a		
		= a <++ termCoder aa s <++ maa_ [] aargs (i+1) s 
	maa_ _ [] _ _ a = a

215 216 217
recordFieldCoder :: ![SaplTypedVar] !StringAppender -> StringAppender
recordFieldCoder [TypedVar t _] a = a <++ "\"" <++ unpackVar t <++ "\""
recordFieldCoder [TypedVar t _:ts] a
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238
	= a <++ "\"" <++ unpackVar t <++ "\"," <++ recordFieldCoder ts
recordFieldCoder [] a = a

termArrayCoder :: ![a] !String !CoderState !StringAppender -> StringAppender | TermCoder a
termArrayCoder [t] sep s a = termCoder t s a
termArrayCoder [t:ts] sep s a
	= a <++ termCoder t s <++ sep <++ termArrayCoder ts sep s
termArrayCoder [] _ s a = a

//----------------------------------------------------------------------------------------
// Term coder instances

class TermCoder a 
where
	termCoder 		:: !a !CoderState !StringAppender -> StringAppender
	forceTermCoder 	:: !a !CoderState !StringAppender -> StringAppender
	trampolineCoder	:: !a !CoderState !StringAppender -> StringAppender

//----------------------------------------------------------------------------------------
// Data constructor...

239
constructorCoder :: !SaplVar !Int ![SaplTypedVar] CoderState !StringAppender -> StringAppender
240 241 242

// A zero argument data constructor is a CAF
constructorCoder name id [] s a
243
	= a <++ "var " <++ escapeName s.cs_prefix (unpackVar name) <++ " = [" <++ id <++ ",\"" <++ unpackVar name <++ "\"];"
244

245
constructorCoder name id args s a
László Domoszlai's avatar
László Domoszlai committed
246
	// Generate $eval function if any of its arguments is annotated as strict	
247 248
	# a = if (any isStrictVar args) 
				(makeStrictClosure (unpackVar name) args s a) a
László Domoszlai's avatar
László Domoszlai committed
249

250
	// Original field names are not necessary, they can be shorten
251
	# newargs = [NormalVar ("_"+++toString i) 0 \\ i <- [1..length args]]
László Domoszlai's avatar
László Domoszlai committed
252
		
253
	# a = a <++ "function " <++ termCoder name s <++ "(" <++ termArrayCoder newargs "," s
254
			<++ "){return [" <++ id <++ "," <++ termCoder name s <++ "$n"
255 256 257
	# a = case length args of
		0 = a
		  = a <++ "," <++ termArrayCoder newargs "," s 
László Domoszlai's avatar
László Domoszlai committed
258 259
	# a = a	<++ "];};"

260
	= a <++ "var " <++ termCoder name s <++ "$n = \"" <++ unpackVar name <++ "\";" 
261

262
constructorInliner :: !SaplVar !ConstructorDef ![SaplTerm] !CoderState !StringAppender -> StringAppender
263 264 265
constructorInliner name def [] s a
	= escapeName s.cs_prefix (unpackVar name) a

266
constructorInliner name def args s a
267
	# a = a <++ "[" <++ def.index <++ "," <++ escapeName s.cs_prefix (unpackVar name) <++ "$n"
268 269
	# a = case def.nr_args of
		0 = a
270
		  = a <++ "," <++ argsCoder def.args args ","  {s & cs_intrfunc = Nothing}  
271
	= a	<++ "]"
László Domoszlai's avatar
László Domoszlai committed
272 273
where
	// Formal arguments, actual arguments
274 275 276
	argsCoder [TypedVar (NormalVar _ _) _] [t] sep s a = termCoder t s a
	argsCoder [TypedVar (StrictVar _ _) _] [t] sep s a = forceTermCoder t s a	
	argsCoder [TypedVar (NormalVar _ _) _:fs] [t:ts] sep s a 
László Domoszlai's avatar
László Domoszlai committed
277
			= a <++ termCoder t s <++ sep <++ argsCoder fs ts sep s
278
	argsCoder [TypedVar (StrictVar _ _) _:fs] [t:ts] sep s a 
László Domoszlai's avatar
László Domoszlai committed
279 280
			= a <++ forceTermCoder t s <++ sep <++ argsCoder fs ts sep s	
	argsCoder [] [] _ s a = a
281

282 283 284 285 286
instance TermCoder SaplConstructor
where
	termCoder (SaplConstructor name id args) s a = constructorCoder name id args s a
	forceTermCoder t s a = termCoder t s a
	trampolineCoder t s a = termCoder t s a
287

288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306
//----------------------------------------------------------------------------------------
// Literals...

instance TermCoder Literal
where
	termCoder (LString ustr) s a = a <++ "\"" <++ toJSLiteral ustr <++ "\""
	termCoder (LChar uchr) s a = a <++ "'" <++ toJSLiteral uchr <++ "'"
	termCoder (LInt int) s a = a <++ int
	termCoder (LReal real) s a = a <++ real
	termCoder (LBool True) s a = a <++ "true"
	termCoder (LBool False) s a = a <++ "false"
	forceTermCoder t s a = termCoder t s a
	trampolineCoder t s a = termCoder t s a

//----------------------------------------------------------------------------------------
// Select patterns...

get_cons_or_die s cons = maybe (abort ("Data constructor "+++cons+++" cannot be found!")) 
			  		   id
307
			   	       ('DM'.get cons s.cs_constructors)
308

309 310 311 312 313 314 315 316 317
splitDefaultPattern :: ![(SaplPattern, SaplTerm)] -> (![(SaplPattern, SaplTerm)], !Maybe SaplTerm)
splitDefaultPattern patterns 
	= case partition (isDefaultPattern o fst) patterns of
			([],ps) 		= (ps, Nothing)
			([(_,d)],ps) 	= (ps, Just d)
							= abort "Error: more than one default branches in a select expression"

containsUnsafeSelect :: !CoderState !SaplTerm -> Bool
containsUnsafeSelect s (SApplication _ ts) = any (containsUnsafeSelect s) ts
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
318
containsUnsafeSelect s (SCase _ ps) = isUnsafeSelect s ps || any (containsUnsafeSelect s) (map snd ps)
319 320 321
containsUnsafeSelect s (SLet b _) = containsUnsafeSelect s b
containsUnsafeSelect s _ = False

322 323 324 325 326 327 328 329 330 331 332
isUsed :: SaplTerm SaplVar -> Bool
isUsed body var = w (unpackVar var) body
where
	w vn (SVar bvar) = unpackVar bvar == vn
	w vn (SApplication bvar bargs) = w vn bvar || any (w vn) bargs
	w vn (SCase bexpr branches) = w vn bexpr || any (w vn) (map snd branches)
	w vn (SLet bexpr bdefs) = w vn bexpr || any (w vn) (map unpackBindExpr bdefs)
	w vn (SSelect bexpr _ _) = w vn bexpr
	w vn (SUpdate bexpr _ updates) = w vn bexpr || any (w vn) (map snd updates)
	w _ _ = False

333 334 335 336 337 338 339 340 341 342
isUnsafeSelect :: !CoderState ![(SaplPattern, SaplTerm)] -> Bool
isUnsafeSelect s patterns
	= case ps of
		[(PCons name _, _):_] = isNothing d && (get_cons_or_die s name).nr_cons <> length ps
		[(PLit (LBool True), _),(PLit (LBool False), _):_] = False
		[(PLit (LBool False), _),(PLit (LBool True), _):_] = False		
		_ = isNothing d
where
	(ps, d) = splitDefaultPattern patterns

343 344 345
instance TermCoder (SaplPattern, SaplTerm, Bool)
where
	termCoder (PDefault, body, _) s a 
346
		= callWrapper body s a
347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366

	termCoder (PLit lit, body, _) s a 
		= a <++ "case " <++ termCoder lit s <++ ": " <++ callWrapper body s

	termCoder (PCons cons [], body, True) s a 
		= callWrapper body s a

	termCoder (PCons cons [], body, False) s a 
		= a <++ "case " <++ toString cons_idx <++ ": " <++ callWrapper body s
	where
		cons_idx  = (get_cons_or_die s cons).index
		
	termCoder (PCons cons args, body, singleton) s a 
		# s = pushArgs s (map annotate (zip2 get_cons.args args))	

		// In the case of singleton data constructor we omit "switch/case"
		# a = case singleton of
				True = a
				_ 	 = a <++ "case " <++ toString get_cons.index <++ ": "

367 368 369 370 371 372
		# (fargs, _) = foldl (\(fs, i) a -> if (isUsed body a) ([(a,i):fs],i+1) (fs,i+1)) ([], 0) args 

		= case fargs of
			[] = a <++ callWrapper body s
			fargs = a <++ "var " <++ instargs (reverse fargs) s <++ callWrapper body s
						
373
	where 
374 375 376
		instargs [(t,i)] s a = a <++ termCoder t s <++ "=ys[" <++ i+2 <++ "];"
		instargs [(t,i):ts] s a = a <++ termCoder t s <++ "=ys[" <++ i+2 <++ "]," <++ instargs ts s
		instargs [] s a = a
377 378 379

		get_cons   = get_cons_or_die s cons

380 381
		annotate (TypedVar (StrictVar _ _) type, arg) = TypedVar (toStrictVar arg) type
		annotate (TypedVar _ type, arg) = TypedVar arg type
382 383 384 385 386 387 388

	forceTermCoder t s a = termCoder t s a
	trampolineCoder t s a = termCoder t s a

//----------------------------------------------------------------------------------------
// Variables...

389 390 391 392 393 394
instance TermCoder SaplTypedVar
where
	forceTermCoder var s a = forceTermCoder (removeTypeInfo var) s a
	trampolineCoder var s a = trampolineCoder (removeTypeInfo var) s a
	termCoder var s a = termCoder (removeTypeInfo var) s a

395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411
instance TermCoder SaplVar
where
	forceTermCoder t=:(NormalVar name level) s a
		// Strict let definitions, strict arguments ...
		| any (eqStrictVar name) s.cs_current_vars
			= a <++ termCoder t s
			
		| isJust mbConstructor && constructor.nr_args == 0
			= constructorInliner t constructor [] s a		

		| isCAF 
			= force (escapeName s.cs_prefix name) a

		| isJust function_args && (length (fromJust function_args) == 0)
			= condForce s.cs_trampoline (\a -> a <++ escapeName s.cs_prefix name <++ "()") a
			= force (termCoder t s) a
	where
412
		mbConstructor = 'DM'.get name s.cs_constructors
413
		constructor = fromJust mbConstructor
414 415
		function_args = 'DM'.get name s.cs_functions	
		isCAF = isJust ('DM'.get name s.cs_CAFs)
416 417 418 419 420

	forceTermCoder (StrictVar name level) s a = forceTermCoder (NormalVar name level) s a

	trampolineCoder t=:(NormalVar name _) s a
		| isJust mbConstructor && constructor.nr_args == 0
421
			= constructorInliner t constructor [] s a
422 423
			= a <++ termCoder t s
	where
424
		mbConstructor = 'DM'.get name s.cs_constructors
425 426 427 428 429 430 431 432 433 434 435 436 437
		constructor = fromJust mbConstructor

	trampolineCoder (StrictVar name level) s a = trampolineCoder (NormalVar name level) s a

	termCoder t=:(NormalVar name level) s a
		| isJust s.cs_inbody && not isLocalVar && isJust mbConstructor && constructor.nr_args == 0
			= constructorInliner t constructor [] s a	
				
		// custom data constructors can be inlined even at non-strict position
		| isJust mbInlineFun && inlineFun.data_cons && inlineFun.arity == 0
			= a <++ "(" <++ inlineFun.fun (\t a = termCoder t s a) (\t a = forceTermCoder t s a) [] <++ ")"
				
		| isJust s.cs_inbody && not isLocalVar && isJust mbCAF
438
			= a <++ escapeName s.cs_prefix name
439 440 441 442
			
		| isJust s.cs_inbody && not isLocalVar && isStrictFunction
			= a <++ escapeName s.cs_prefix name <++ "$eval"	

443
			// else (TODO: probably bogus in tail-recursion...)
444
			| any (eqVarByNameLevel t) (map removeTypeInfo s.cs_futuredefs)
445 446
				= a <++ "[function(){return " <++ force var_name <++ ";},[]]"

447 448
			// else: use the defined name if its a built-in function, otherwise its a variable...
			// no prefix for built-in functions
449
			= a <++ (maybe var_name (escapeName "" o fst) ('DM'.get name s.cs_builtins))			  
450
	where
451
		mbInlineFun = 'DM'.get name s.cs_inlinefuncs
452
		inlineFun = fromJust mbInlineFun
453
		mbConstructor = 'DM'.get name s.cs_constructors
454
		constructor = fromJust mbConstructor
455
		mbCAF = 'DM'.get name s.cs_CAFs
456 457

		// TODO: doc
458 459
		findLocalVar [TypedVar (NormalVar cn level) _:cs] = if (cn == name) level (findLocalVar cs)
		findLocalVar [TypedVar (StrictVar cn level) _:cs] = if (cn == name) level (findLocalVar cs)
460
		findLocalVar [] = 0
461
		isLocalVar = elem_by eqVarByName t (map removeTypeInfo s.cs_current_vars) //isMember t s.cs_current_vars
462
		
463
		isFunction = isJust ('DM'.get t s.cs_functions)		
464 465
		isStrictFunction = a || b
		where
466 467
			a = maybe False (any isStrictVar) ('DM'.get name s.cs_functions)
			b = maybe False (\{args} -> any isStrictVar args) ('DM'.get name s.cs_constructors)
468 469 470 471 472 473 474 475 476 477

		var_name a # decl_level = findLocalVar s.cs_current_vars
				   = case decl_level of
						0 = a <++ escapeName s.cs_prefix name
						  = a <++ escapeName s.cs_prefix name <++ "_" <++ decl_level

	termCoder (StrictVar name level) s a = termCoder (NormalVar name level) s a

//----------------------------------------------------------------------------------------
// Let definitions...
478 479 480 481 482

/*
 * A let definition is not the spine of the function, avoid tail recursion optimization:
 * {s & cs_intrfunc = Nothing}
 */
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
483 484 485 486 487 488 489 490 491 492 493 494 495 496
letDefCoder :: ![SaplLetDef] !Bool !CoderState !StringAppender -> StringAppender
letDefCoder [t] needsvar s a | inline (unpackBindExpr t) 
		= a <++ if needsvar "var " "," <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=[toNormalVar (unpackBindVar t)]} <++ ";\n "
		= a <++ if needsvar "" ";\n" <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=[toNormalVar (unpackBindVar t)]} <++ ";\n "
		
letDefCoder all=:[t:ts] needsvar s a | inline (unpackBindExpr t) 
	= a <++ if needsvar "var " "," <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=fvs} 
		<++ letDefCoder ts False {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
where
	fvs = map (toNormalVar o unpackBindVar) all

letDefCoder all=:[t:ts] needsvar s a
	= a <++ if needsvar "" ";\n" <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=fvs} <++ ";\n"
		<++ letDefCoder ts True {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
497 498
where
	fvs = map (toNormalVar o unpackBindVar) all
499

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
500
letDefCoder [] _ _ a = a
501 502

isDependent :: ![SaplVar] !SaplTerm -> Bool 
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
503
isDependent vs (SApplication (SVar f) as) = any (isDependent vs) [SVar f:as]
504 505 506
isDependent vs (SVar v) = elem_by eqVarByNameLevel v vs
isDependent _ _ = False

507
instance TermCoder SaplLetDef
508
where
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
509
	termCoder (SaplLetDef name body) s a | inline body
510 511
		= a <++ termCoder name {s & cs_futuredefs = []} <++ "=" 
			<++ (if (isStrictVar name) forceTermCoder termCoder) body s
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
512 513 514

	termCoder (SaplLetDef name body) s a
		= a <++ (if (isStrictVar name) forceTermCoder termCoder) body {s & cs_inletbind = Just name}
515
			
516 517
	forceTermCoder t s a = termCoder t s a
	trampolineCoder t s a = termCoder t s a
518

519 520
//----------------------------------------------------------------------------------------
// Expressions...
521

522
instance TermCoder SaplTerm
523
where
524 525 526
	// Generate code that forces the evaluation of the given term
	forceTermCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
	forceTermCoder t=:(SVar var) s a = forceTermCoder var s a
527
	
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
528
	forceTermCoder t=:(SApplication (SVar name) args) s a
529 530
		| isJust mbConstructor && constructor.nr_args == length args
			= constructorInliner name constructor args s a
531

532
		| isJust mbFunction && functionArity == length args
533

534 535 536 537 538 539 540 541 542 543
			= case (isJust s.cs_intrfunc && isTailRecursive (fromJust s.cs_intrfunc) t) of
				
				// It is posible that a tail recursive call has the same function as its
				// argument. In this case, the deeper call cannot be handled as tail recursive!
				True 	= a <++ make_tr_app args {s & cs_intrfunc = Nothing}	
				_		= condForce s.cs_trampoline 
							(\a -> a <++ func_name <++ "(" <++ make_app_args name args {s & cs_intrfunc = Nothing} <++ ")") a
				
		// more arguments than needed: split it
		| isJust mbFunction && functionArity < length args
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
544
			= forceApp (\a -> a <++ forceTermCoder (SApplication (SVar name) (take functionArity args)) s <++ ",[" 
545 546 547 548 549 550 551
							 <++ termArrayCoder (drop functionArity args) "," {s & cs_intrfunc = Nothing} <++ "]") a
				
		| isJust mbInlineFun && inlineFun.arity == length args
			= a <++ "(" <++ inlineFun.fun 
				(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
				(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) args <++ ")"

552 553 554 555 556 557 558
		// more arguments than needed: split it
		| isJust mbInlineFun && inlineFun.arity < length args
			= forceApp (\a -> a <++ inlineFun.fun 
										(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
										(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) (take inlineFun.arity args) <++ ",[" 
							 <++ termArrayCoder (drop inlineFun.arity args) "," {s & cs_intrfunc = Nothing} <++ "]") a
							 
559 560 561 562 563 564 565 566 567 568 569
		// BINs return no thunk, there is no need for feval even in trampolining
		// no prefix for built-in functions
		| isJust builtin && (snd (fromJust builtin)) == length args
			= a <++ escapeName "" (fst (fromJust builtin)) <++ "(" <++ make_app_args name args {s & cs_intrfunc = Nothing} <++ ")"

		// E.g.: in higher order functions application to argument
		| isNothing mbFunction && isNothing builtin
			= forceApp (\a -> a <++ termCoder name s <++ ",[" <++ termArrayCoder args "," s <++ "]") a

		// Otherwise: partial function application 
			= a <++ termCoder t s
570
			
571 572 573
	where
		func_name a = a <++ escapeName s.cs_prefix (unpackVar name) // skip level information

574
		mbConstructor = 'DM'.get (unpackVar name) s.cs_constructors
575
		constructor = fromJust mbConstructor
576
		mbInlineFun = 'DM'.get (unpackVar name) s.cs_inlinefuncs
577
		inlineFun = fromJust mbInlineFun
578
		mbFunction = 'DM'.get (unpackVar name) s.cs_functions
579 580 581
		functionArgs = fromJust mbFunction
		functionArity = length functionArgs

582 583
		tr_function_args = fromJust ('DM'.get (unpackVar (fromJust s.cs_intrfunc)) s.cs_functions)
		builtin = 'DM'.get (unpackVar name) s.cs_builtins
584

585
		make_tr_app args s a
586 587 588 589 590 591 592 593 594
			# setters = filter (not o isSame) (zip2 tr_function_args args)
			= case sortSetters setters of
				Nothing
					# (tr_function_args, args) = unzip setters	
					= a <++ "var " <++ mta_1 tr_function_args args 0 s <++ ";" 
						<++ mta_2 tr_function_args 0 s <++ "continue;"
				// Reverse topological order is probably safe
				(Just ordered) = a <++ gen_setters (reverse ordered) s <++ "continue;"
				
595
		where
596
			mta_1 [TypedVar (StrictVar _ _) _:fargs] [aa:aargs] i s a 
597 598 599 600 601 602 603 604 605 606 607
				# a = if (i>0) (a <++ ",") a
				= a <++ "t" <++ i <++ "=" <++ forceTermCoder aa s <++ mta_1 fargs aargs (i+1) s 
			mta_1 [_:fargs] [aa:aargs] i s a 
				# a = if (i>0) (a <++ ",") a		
				= a <++ "t" <++ i <++ "=" <++ termCoder aa s <++ mta_1 fargs aargs (i+1) s 
			mta_1 [] _ i s a = a

			mta_2 [fa:fargs] i s a 
				= a <++ escapeName s.cs_prefix (unpackVar fa) <++ "=t" <++ i <++ ";" <++ mta_2 fargs (i+1) s // skip level information for TR!
			mta_2 [] i s a = a

608 609 610
			isSame (TypedVar var1 _, SVar var2) = unpackVar var1 == unpackVar var2
			isSame _ = False

611 612 613 614 615 616
			gen_setters [(TypedVar (StrictVar vn _) _,expr):ss] s a 
				= a <++ escapeName s.cs_prefix vn <++ "=" <++ forceTermCoder expr s <++ ";" <++ gen_setters ss s
			gen_setters [(TypedVar (NormalVar vn _) _,expr):ss] s a 
				= a <++ escapeName s.cs_prefix vn <++ "=" <++ termCoder expr s <++ ";" <++ gen_setters ss s
			gen_setters [] s a = a

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
617
	forceTermCoder (SApplication sel=:(SSelect _ _ _) args) s a
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
618 619 620 621
		= a <++ "Sapl.fapp(" <++ forceTermCoder sel s <++ ",["  
				<++ termArrayCoder args "," s
				<++ "])"

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642
	forceTermCoder t=:(SSelect expr type idx) s a 
		| isStrict idx 
			= a <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "]"
			= a <++ "Sapl.feval(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "])"
	where
		strictness = strictnessMap type s
		isStrict idx = (strictness bitand (2 << idx)) > 0
	
	// It is always in a strict let bind
	forceTermCoder t=:(SUpdate expr type updates) s a
      = a <++ "var " <++ termCoder var {s & cs_inletbind = Nothing, cs_futuredefs = []} <++ "=" <++ forceTermCoder expr {s & cs_inletbind = Nothing} <++ ".slice(0);" <++ genUpd updates;
	where
		var = fromJust s.cs_inletbind
	
		strictness = strictnessMap type s
		isStrict idx = (strictness bitand (2 << idx)) > 0
	
		genUpd [] a = a
		genUpd [(idx, expr):us] a 
			= a <++ termCoder var {s & cs_inletbind = Nothing, cs_futuredefs = []} <++ "[" <++ idx + 2 <++ "]=" <++ 
			(if (isStrict idx) forceTermCoder termCoder) expr {s & cs_inletbind = Nothing} <++ ";" <++ genUpd us
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
643

644 645 646 647 648
	forceTermCoder t s a = termCoder t s a

	// During trampolining, in only very special cases the expressions are forced in tail call
	trampolineCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
	trampolineCoder t=:(SVar var) s a = trampolineCoder var s a
649
		
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
650
	trampolineCoder t=:(SApplication (SVar name) args) s a
651 652
		| isJust mbConstructor && constructor.nr_args == length args
			= constructorInliner name constructor args s a	
653

654 655 656 657
		| isJust mbInlineFun && inlineFun.arity == length args
			= a <++ "(" <++ inlineFun.fun 
				(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
				(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) args <++ ")"
658

659
			= a <++ termCoder t s
László Domoszlai's avatar
László Domoszlai committed
660
	where
661
		mbConstructor = 'DM'.get (unpackVar name) s.cs_constructors
662
		constructor = fromJust mbConstructor
663
		mbInlineFun = 'DM'.get (unpackVar name) s.cs_inlinefuncs
664
		inlineFun = fromJust mbInlineFun
László Domoszlai's avatar
László Domoszlai committed
665

666
	trampolineCoder t s a = termCoder t s a
667

668 669
	termCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
	termCoder t=:(SVar var) s a = termCoder var s a
670
		
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
671 672 673 674 675 676 677 678 679 680 681
	termCoder t=:(SSelect expr type idx) s a
		| isStrict idx
			= a <++ "[Sapl.sselect,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"
			= a <++ "[Sapl.select,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"			
	where
		strictness = strictnessMap type s
		isStrict idx = (strictness bitand (2 << idx)) > 0

	// Should not happen, at thi spoint "update" is always at strict position
	termCoder t=:(SUpdate _ _ _) s a
      = a <++ "/* UPD */"
682

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
683
	termCoder t=:(SCase expr patterns) s a | any (isConsPattern o fst) patterns
684
		# a = a <++ "var ys=" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++  ";"
685
		= if (containsUnsafeSelect s t) (unsafe a) (safe a)
686
	where 
687 688 689 690 691
		isSingleton cons = (get_cons_or_die s cons).nr_cons == 1
		addSwitch e a = a <++ "switch(ys[0]){" <++ e <++ "};"
		(ps, d) = splitDefaultPattern patterns	

		// Something is very wrong with type inference here
692
		
693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716
		ups :: [(SaplPattern, SaplTerm, Bool)]
		ups = map (\(p,b)=(p,b,False)) ps

		defp :: SaplTerm Bool -> (SaplPattern, SaplTerm, Bool)
		defp d b = (PDefault,d,b)

		cp :: SaplPattern SaplTerm Bool -> (SaplPattern, SaplTerm, Bool)
		cp p d b = (p,d,b)

		unsafe a
			# a = addSwitch (termArrayCoder ups "" {s & cs_incaseexpr = True}) a
			= case d of
				(Just d) = a <++ termCoder (defp d False) s <++ ";"
						 = a <++ (if s.cs_incaseexpr "break;" "throw \"nomatch\";")
						 
		safe a
			# a = case patterns of
					[(p,body)] = if (isSingleton (fromJust (unpackConsName p))) 
										(termCoder (cp p body True) s a)
										(addSwitch (termCoder (cp p body False) s) a)
							   = addSwitch (termArrayCoder ups "" s) a
			= case d of
				(Just d) = a <++ termCoder (defp d False) s <++ ";"
						 = a
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
717 718 719 720 721 722

	termCoder t=:(SCase expr [(PLit (LBool True), true_expr),(PLit (LBool False), false_expr)]) s a
		= termCodeIf expr true_expr false_expr s a

	termCoder t=:(SCase expr [(PLit (LBool False), false_expr),(PLit (LBool True), true_expr)]) s a
		= termCodeIf expr true_expr false_expr s a
723
	
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
724
	termCoder t=:(SCase expr patterns) s a
725
	    # a = a <++ "switch(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "){" 
László Domoszlai's avatar
László Domoszlai committed
726
	            <++ termArrayCoder (map (\(p,b)=(p,b,False)) ps) "" {s & cs_incaseexpr = True} <++ "};"
727 728 729 730 731 732
		= case d of
			(Just d) = a <++ termCoder (PDefault,d,False) s <++ ";"
					 = a <++ (if s.cs_incaseexpr "break;" "throw \"nomatch\";")			
	where
		(ps, d) = splitDefaultPattern patterns

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
733
	termCoder (SApplication (SVar name) args) s a
734 735 736 737 738 739 740 741 742 743 744 745 746 747
		// It's only safe if there is no immediate evaluation
		| isJust mbConstructor && constructor.nr_args == length args && not (any isStrictVar constructor.args)
			= constructorInliner name constructor args s a	
		
		// custom data constructors can be inlined even at non-strict position
		| isJust mbInlineFun && inlineFun.data_cons && inlineFun.arity == length args
			= a <++ "(" <++ inlineFun.fun 
				(\t a = termCoder t {s & cs_intrfunc = Nothing} a)
				(\t a = forceTermCoder t {s & cs_intrfunc = Nothing} a) args <++ ")"
					
			= a <++ "[" <++ termCoder name s <++ ",[" 
				<++ termArrayCoder args "," s
				<++ "]]"
	where
748
		mbConstructor = 'DM'.get (unpackVar name) s.cs_constructors
749 750 751
		constructor = fromJust mbConstructor
		func_name name a = a <++ escapeName s.cs_prefix (unpackVar name) // skip level information

752
		mbInlineFun = 'DM'.get (unpackVar name) s.cs_inlinefuncs
753 754
		inlineFun = fromJust mbInlineFun

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
755
    // Dynamic application: fun part is always strict
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
756
	termCoder (SApplication sel=:(SSelect _ _ _) args) s a
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
757 758 759 760
		= a <++ "[" <++ forceTermCoder sel s <++ ",["  
				<++ termArrayCoder args "," s
				<++ "]]"

761 762 763 764 765 766 767 768 769 770
	termCoder (SLit lit) s a = termCoder lit s a

	/* Let definitions can be cross references to each other.
	 * If a let definition has reference to an other which is not yet declared
	 * (or recursive) the referenced variable must be wrap into a closure.
	 * cs_inletdef contains all the remaining let definitions (letDefCoder 
	 * removes the elements step by step)
	 */
	termCoder (SLet body defs) s a
		# s = pushArgs s defnames
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
771
		= a <++ letDefCoder newdefs True s
772 773
			<++ callWrapper body {s & cs_current_vars = defnames ++ s.cs_current_vars} <++ ";"
	where
774 775
		newdefs = case sortBindings defs of
						Just ds = ds
776 777
						Nothing = defs
						//Nothing = abort ("Cycle in let definitions is detected in function "+++toString (fromJust s.cs_inbody)+++"\n") // This is not supported currently
778

779
		defnames = map unpackBindVar newdefs
780

Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
781 782 783 784 785 786 787 788 789 790
termCodeIf cond_expr true_expr false_expr s a 
	| inline cond_expr && inline true_expr && inline false_expr && 
	  not (isJust s.cs_intrfunc && (isTailRecursive (fromJust s.cs_intrfunc) true_expr || isTailRecursive (fromJust s.cs_intrfunc) false_expr))
	    = a <++ "(" <++ forceTermCoder cond_expr {s & cs_intrfunc = Nothing} <++ "?" 
	        <++ forceTermCoder true_expr {s & cs_incaseexpr = True} <++ ":" <++ forceTermCoder false_expr {s & cs_incaseexpr = True} <++ ")"

termCodeIf cond_expr texpr fexpr s a
	    = a <++ "if(" <++ forceTermCoder cond_expr {s & cs_intrfunc = Nothing} <++ "){" 
	        <++ callWrapper texpr {s & cs_incaseexpr = True} <++ "}else{" <++ callWrapper fexpr {s & cs_incaseexpr = True} <++ "}"
	
791 792
generateJS :: !Flavour !Bool !String !(Maybe ParserState) -> MaybeErrorString (StringAppender, ParserState)
generateJS f tramp saplsrc mbPst
793 794
	# pts = tokensWithPositions saplsrc
	= case parse pts of
795
		Ok (funcs, s) # newpst = mergeParserStates s mbPst
796
					  # (funcs, newpst) = if (isSet f "enableStrictnessPropagation") (doStrictnessPropagation newpst (isStrictArgFlavour f) funcs) (funcs, newpst)
797
					  # state = newState f tramp newpst
László Domoszlai's avatar
László Domoszlai committed
798 799
					  # a = newAppender <++ "\"use strict\";"
					  # a = a <++ "/*Trampoline: "
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
800 801 802 803 804 805 806
					  # a = if tramp (a <++ "ON") (a <++ "OFF")
					  
					  // Lift + generated update functions
					  # (funcs, genfuns) = foldl (upd (isStrictArgFlavour f newpst)) ([], newMap) funcs
					  # funcs = reverse funcs ++ elems genfuns 
					  
					  # a = foldl (\a curr = a <++ funcCoder curr state) (a <++ "*/") funcs
807
					  = Ok (a, newpst)
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
808 809 810 811 812 813
		Error msg = Error msg	
where		
  upd :: (!String !Int !Int -> Bool) ([FuncType], Map String FuncType) FuncType -> ([FuncType], Map String FuncType)
  upd sf (nfs, genfuns) fun 
  	= let (nfun, ngenfuns) = prepareFun sf fun genfuns in ([nfun:nfs], union genfuns ngenfuns)
  		
814 815
exprGenerateJS :: !Flavour !Bool !String !(Maybe ParserState) !StringAppender -> (MaybeErrorString (String, StringAppender, ParserState))
exprGenerateJS f tramp saplsrc mbPst out
816 817
	# pts = tokensWithPositions saplsrc
	= case parseExpr pts of
818 819
		Ok (body, s) # newpst = mergeParserStates s mbPst
					 # state = newState f tramp newpst
Laszlo Domoszlai's avatar
Laszlo Domoszlai committed
820 821 822 823 824
					 
					  // Lift + generated update functions. TODO: do not skip generated functions
					  # (body, _) = prepareExpr (isStrictArgFlavour f newpst) body newMap
					 
					 # a = termCoder body {state & cs_inbody=Just (TypedVar (NormalVar "__dummy" 0) NoType)} newAppender
825 826 827
					 # out = foldl (\a curr = a <++ funcCoder curr state) out s.ps_genFuns
					 = Ok (toString a, out, newpst)
		Error msg = Error msg
László Domoszlai's avatar
László Domoszlai committed
828