@@ -64,6 +64,7 @@ data JS = JSRaw String
6464 | JSArray [JS]
6565 | JSObject [(String, JS)]
6666 | JSString String
67+ | JSChar String
6768 | JSNum JSNum
6869 | JSAssign JS JS
6970 | JSAlloc String (Maybe JS)
@@ -153,6 +154,9 @@ compileJS (JSObject fields) =
153154compileJS (JSString str) =
154155 show str
155156
157+compileJS (JSChar chr) =
158+ chr
159+
156160compileJS (JSNum num)
157161 | JSInt i <- num = show i
158162 | JSFloat f <- num = show f
@@ -170,8 +174,16 @@ compileJS (JSIndex lhs rhs) =
170174 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
171175
172176compileJS (JSCond branches) =
173− intercalate " else " $ map createIfBlock branches
177+ intercalate " else " $ map createIfBlock (eliminateDeadBranches branches)
174178 where
179+ eliminateDeadBranches (e@(JSTrue, _):_) = [e]
180+ eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
181+ eliminateDeadBranches [] = []
182+
183+ createIfBlock (JSTrue, e) =
184+ "{\n"
185+ ++ "return " ++ compileJS e
186+ ++ ";\n}"
175187 createIfBlock (cond, e) =
176188 "if (" ++ compileJS cond ++") {\n"
177189 ++ "return " ++ compileJS e
@@ -233,6 +245,7 @@ jsLet name value body =
233245 )
234246 ) [value]
235247
248+
236249jsSubst :: String -> JS -> JS -> JS
237250jsSubst var new (JSVar old)
238251 | var == translateVariableName old = new
@@ -260,6 +273,16 @@ jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
260273 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)
261274 )]
262275
276+jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
277+ | var `notElem` args =
278+ JSApp (JSProj (JSFunction args (jsSubst var new body)) "apply") (
279+ map (jsSubst var new) vals
280+ )
281+ | otherwise =
282+ JSApp (JSProj (JSFunction args body) "apply") (
283+ map (jsSubst var new) vals
284+ )
285+
263286jsSubst var new (JSApp (JSProj obj field) args) =
264287 JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args
265288
@@ -293,7 +316,38 @@ jsSubst var new (JSCond conds) =
293316
294317jsSubst _ _ js = js
295318
319+
320+isJSConstant :: JS -> Bool
321+isJSConstant js
322+ | JSString _ <- js = True
323+ | JSChar _ <- js = True
324+ | JSNum _ <- js = True
325+ | JSType _ <- js = True
326+
327+ | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
328+ | otherwise = False
329+
296330inlineJS :: JS -> JS
331+inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
332+ JSThis,JSProj (JSIdent var) "vars"
333+ ])
334+ | var /= "cse" =
335+ inlineApply args body 0
336+ where
337+ inlineApply [] body _ = body
338+ inlineApply (a:as) body n =
339+ inlineApply as (
340+ jsSubst a (JSIndex (JSProj (JSIdent var) "vars") (JSNum (JSInt n))) body
341+ ) (n + 1)
342+
343+inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
344+ | isJSConstant val = val
345+
346+inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
347+ JSFunction [] (JSReturn val)
348+ ])
349+ | isJSConstant val = val
350+
297351inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
298352 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
299353
@@ -365,6 +419,9 @@ inlineJS (JSCond cases) =
365419inlineJS (JSObject fields) =
366420 JSObject (map (second inlineJS) fields)
367421
422+inlineJS (JSOp op lhs rhs) =
423+ JSOp op (inlineJS lhs) (inlineJS rhs)
424+
368425inlineJS js = js
369426
370427reduceJS :: [JS] -> [JS]
@@ -536,6 +593,12 @@ reduceLoop reduced (cons, program) =
536593 reduceCall funs (JSProj obj field) =
537594 JSProj (reduceCall funs obj) field
538595
596+ reduceCall funs (JSIndex obj idx) =
597+ JSIndex (reduceCall funs obj) (reduceCall funs idx)
598+
599+ reduceCall funs (JSOp op rhs lhs) =
600+ JSOp op (reduceCall funs rhs) (reduceCall funs lhs)
601+
539602 reduceCall funs (JSCond conds) =
540603 JSCond $ map (reduceCall funs *** reduceCall funs) conds
541604
@@ -699,6 +762,9 @@ translateSpecialName name
699762translateConstant :: Const -> JS
700763translateConstant (I i) = JSNum (JSInt i)
701764translateConstant (Fl f) = JSNum (JSFloat f)
765+translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
766+translateConstant (Ch '\a') = JSChar "'\\u0007'"
767+translateConstant (Ch '\SO') = JSChar "'\\u000E'"
702768translateConstant (Ch c) = JSString [c]
703769translateConstant (Str s) = JSString s
704770translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
@@ -800,23 +866,16 @@ translateDeclaration (path, SFun name params stackSize body)
800866 JSFunction (p ++ map snd aux) (
801867 JSSeq $
802868 zipWith assignVar [0..] p ++
803− map allocVar [numP .. (numP + stackSize - 1)] ++
804869 map assignAux aux ++
805870 [JSReturn body]
806871 )
807872 where
808− numP :: Int
809− numP = length params
810−
811− allocVar :: Int -> JS
812− allocVar n = JSAlloc (jsVar n) Nothing
813−
814873 assignVar :: Int -> String -> JS
815874 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
816875
817876 assignAux :: (LVar, String) -> JS
818− assignAux (var, val) =
819− JSAssign (JSIdent $ translateVariableName var) (JSIdent val)
877+ assignAux (Loc var, val) =
878+ JSAlloc (jsVar var) (Just $ JSIdent val)
820879
821880 p :: [String]
822881 p = map translateName params