git.iko.soy/Idris-dev
on master help sign in
optimize: more
a16a24fbe5invis
src/IRTS/JavaScript/AST.hs+4
compare with master
unifiedsplit
@@ -66,6 +66,8 @@ data JsExpr
66 JsStmt
66 JsStmt
67 | JsApp JsExpr
67 | JsApp JsExpr
68 [JsExpr]
68 [JsExpr]
69+ | JsNew JsExpr
70+ [JsExpr]
69 | JsPart JsExpr
71 | JsPart JsExpr
70 Text
72 Text
71 | JsMethod JsExpr
73 | JsMethod JsExpr
@@ -237,6 +239,8 @@ jsAst2Text (JsLambda args body) =
237 ]
239 ]
238jsAst2Text (JsApp fn args) =
240jsAst2Text (JsApp fn args) =
239 T.concat [jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]
241 T.concat [jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]
242+jsAst2Text (JsNew fn args) =
243+ T.concat ["new ", jsAst2Text fn, "(", T.intercalate ", " $ map jsAst2Text args, ")"]
240jsAst2Text (JsMethod obj name args) =
244jsAst2Text (JsMethod obj name args) =
241 T.concat
245 T.concat
242 [ jsAst2Text obj
246 [ jsAst2Text obj
src/IRTS/JavaScript/Codegen.hs+80−27
@@ -49,10 +49,16 @@ data CGStats = CGStats { usedWriteStr :: Bool
49 , usedReadStr :: Bool
49 , usedReadStr :: Bool
50 , usedBigInt :: Bool
50 , usedBigInt :: Bool
51 , partialApplications :: Set Partial
51 , partialApplications :: Set Partial
52+ , hiddenClasses :: Set HiddenClass
52 }
53 }
53
54
54emptyStats :: CGStats
55emptyStats :: CGStats
55−emptyStats = CGStats {usedWriteStr = False, partialApplications = Set.empty, usedBigInt = False, usedReadStr = False}
56+emptyStats = CGStats { usedWriteStr = False
57+ , partialApplications = Set.empty
58+ , hiddenClasses = Set.empty
59+ , usedBigInt = False
60+ , usedReadStr = False
61+ }
56
62
57data CGConf = CGConf { header :: Text
63data CGConf = CGConf { header :: Text
58 , footer :: Text
64 , footer :: Text
@@ -112,6 +118,7 @@ codegenJs conf ci =
112 , jsbn
118 , jsbn
113 , initialization conf stats
119 , initialization conf stats
114 , doPartials (partialApplications stats)
120 , doPartials (partialApplications stats)
121+ , doHiddenClasses (hiddenClasses stats)
115 , includes, "\n"
122 , includes, "\n"
116 , runtimeCommon, "\n"
123 , runtimeCommon, "\n"
117 , extraRT, "\n"
124 , extraRT, "\n"
@@ -133,11 +140,22 @@ doPartials x =
133 JsFun (jsNamePartial p) vars1 $ JsReturn $
140 JsFun (jsNamePartial p) vars1 $ JsReturn $
134 jsCurryLam vars2 (jsAppN (jsName n) (map JsVar (vars1 ++ vars2)) )
141 jsCurryLam vars2 (jsAppN (jsName n) (map JsVar (vars1 ++ vars2)) )
135
142
143+doHiddenClasses :: Set HiddenClass -> Text
144+doHiddenClasses x =
145+ T.intercalate "\n" (map f $ Set.toList x)
146+ where
147+ f p@(HiddenClass n id arity) =
148+ let vars = map dataPartName $ take arity [1..]
149+ in jsStmt2Text $
150+ JsFun (jsNameHiddenClass p) vars $ JsSeq (JsSet (JsProp JsThis "type") (JsInt id)) $ seqJs
151+ $ map (\tv -> JsSet (JsProp JsThis tv) (JsVar tv)) vars
152+
136doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)
153doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)
137doCodegen conf defs decls =
154doCodegen conf defs decls =
138 let xs = map (doCodegenDecl conf defs) decls
155 let xs = map (doCodegenDecl conf defs) decls
139 groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y
156 groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y
140 , partialApplications = partialApplications x `Set.union` partialApplications y
157 , partialApplications = partialApplications x `Set.union` partialApplications y
158+ , hiddenClasses = hiddenClasses x `Set.union` hiddenClasses y
141 , usedBigInt = usedBigInt x || usedBigInt y
159 , usedBigInt = usedBigInt x || usedBigInt y
142 , usedReadStr = usedReadStr x || usedReadStr y
160 , usedReadStr = usedReadStr x || usedReadStr y
143 }
161 }
@@ -165,6 +183,7 @@ data CGBodyState = CGBodyState { defs :: Map Name LDecl
165 , usedRead :: Bool
183 , usedRead :: Bool
166 , usedITBig :: Bool
184 , usedITBig :: Bool
167 , partialApps :: Set Partial
185 , partialApps :: Set Partial
186+ , hiddenCls :: Set HiddenClass
168 }
187 }
169
188
170getNewCGName :: State CGBodyState Text
189getNewCGName :: State CGBodyState Text
@@ -179,6 +198,10 @@ addPartial :: Partial -> State CGBodyState ()
179addPartial p =
198addPartial p =
180 modify (\s -> s {partialApps = Set.insert p (partialApps s) })
199 modify (\s -> s {partialApps = Set.insert p (partialApps s) })
181
200
201+addHiddenClass :: HiddenClass -> State CGBodyState ()
202+addHiddenClass p =
203+ modify (\s -> s {hiddenCls = Set.insert p (hiddenCls s) })
204+
182addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
205addUsedArgsTailCallOptim :: Set (Text, Text) -> State CGBodyState ()
183addUsedArgsTailCallOptim p =
206addUsedArgsTailCallOptim p =
184 modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
207 modify (\s -> s {usedArgsTailCallOptim = Set.union p (usedArgsTailCallOptim s) })
@@ -226,12 +249,14 @@ cgFun cnf dfs n args def = do
226 , usedRead = False
249 , usedRead = False
227 , usedITBig = False
250 , usedITBig = False
228 , partialApps = Set.empty
251 , partialApps = Set.empty
252+ , hiddenCls = Set.empty
229 }
253 }
230 )
254 )
231 let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res
255 let body = if isTailRec st then JsSeq (declareUsedOptimArgs $ usedArgsTailCallOptim st) (JsForever ((seqJs decs) `JsSeq` res)) else (seqJs decs) `JsSeq` res
232 let fn = JsFun fnName argNames body
256 let fn = JsFun fnName argNames body
233 let state' = CGStats { usedWriteStr = usedWrite st
257 let state' = CGStats { usedWriteStr = usedWrite st
234 , partialApplications = partialApps st
258 , partialApplications = partialApps st
259+ , hiddenClasses = hiddenCls st
235 , usedBigInt = usedITBig st
260 , usedBigInt = usedITBig st
236 , usedReadStr = usedRead st
261 , usedReadStr = usedRead st
237 }
262 }
@@ -281,12 +306,36 @@ cgBody rt expr =
281 | (ff == qualifyN "Prelude.Bool" "False" &&
306 | (ff == qualifyN "Prelude.Bool" "False" &&
282 tt == qualifyN "Prelude.Bool" "True") ->
307 tt == qualifyN "Prelude.Bool" "True") ->
283 case (Map.lookup oper primDB) of
308 case (Map.lookup oper primDB) of
284− Just (useBigInt, pti, combinator) | pti == PTBool -> do
309+ Just (needBI, pti, c) | pti == PTBool -> do
285 z <- mapM (cgBody GetExpBT) [x, y]
310 z <- mapM (cgBody GetExpBT) [x, y]
286− when useBigInt setUsedITBig
311+ when needBI setUsedITBig
287− let res = jsPrimCoerce pti PTBool $ combinator $ map (jsStmt2Expr . snd) z
312+ let res = jsPrimCoerce pti PTBool $ c $ map (jsStmt2Expr . snd) z
288 pure $ (concat $ map fst z, addRT rt res)
313 pure $ (concat $ map fst z, addRT rt res)
289 _ -> cgBody' rt expr
314 _ -> cgBody' rt expr
315+ (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LDefaultCase (LCon _ _ ff [])])
316+ | (ff == qualifyN "Prelude.Bool" "False" &&
317+ tt == qualifyN "Prelude.Bool" "True") -> do
318+ (d, v) <- cgBody GetExpBT e
319+ test <- formConTest n (jsStmt2Expr v)
320+ pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
321+ (LCase _ e [LConCase _ n _ (LCon _ _ tt []), LConCase _ _ _ (LCon _ _ ff [])])
322+ | (ff == qualifyN "Prelude.Bool" "False" &&
323+ tt == qualifyN "Prelude.Bool" "True") -> do
324+ (d, v) <- cgBody GetExpBT e
325+ test <- formConTest n (jsStmt2Expr v)
326+ pure $ (d, addRT rt $ JsUniOp (T.pack "!") $ JsUniOp (T.pack "!") test)
327+ (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LDefaultCase (LCon _ _ tt [])])
328+ | (ff == qualifyN "Prelude.Bool" "False" &&
329+ tt == qualifyN "Prelude.Bool" "True") -> do
330+ (d, v) <- cgBody GetExpBT e
331+ test <- formConTest n (jsStmt2Expr v)
332+ pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
333+ (LCase _ e [LConCase _ n _ (LCon _ _ ff []), LConCase _ _ _ (LCon _ _ tt [])])
334+ | (ff == qualifyN "Prelude.Bool" "False" &&
335+ tt == qualifyN "Prelude.Bool" "True") -> do
336+ (d, v) <- cgBody GetExpBT e
337+ test <- formConTest n (jsStmt2Expr v)
338+ pure $ (d, addRT rt $ JsUniOp (T.pack "!") test)
290 (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq])
339 (LCase f e [LConCase nf ff [] alt, LConCase nt tt [] conseq])
291 | (ff == qualifyN "Prelude.Bool" "False" &&
340 | (ff == qualifyN "Prelude.Bool" "False" &&
292 tt == qualifyN "Prelude.Bool" "True") ->
341 tt == qualifyN "Prelude.Bool" "True") ->
@@ -328,8 +377,9 @@ cgBody' rt (LApp tailcall (LV (Glob fn)) args) =
328 do
377 do
329 argsFn <- getArgList fn
378 argsFn <- getArgList fn
330 case argsFn of
379 case argsFn of
331− Nothing ->
380+ Nothing -> do
381+ fn' <- cgName fn
332− pure (preDecs, addRT rt $ jsCurryApp (JsVar fname) argVals )
382+ pure (preDecs, addRT rt $ jsCurryApp fn' argVals )
333 Just agFn ->
383 Just agFn ->
334 do
384 do
335 let lenAgFn = length agFn
385 let lenAgFn = length agFn
@@ -428,10 +478,10 @@ formCon n args = do
428 Nothing -> do
478 Nothing -> do
429 (conId, arity) <- getConsId n
479 (conId, arity) <- getConsId n
430 if (arity > 0)
480 if (arity > 0)
431− then pure $
481+ then do
432− JsObj $
482+ let hc = HiddenClass n conId arity
433− (T.pack "type", JsInt conId) :
483+ addHiddenClass hc
434− zip (map (\i -> T.pack $ "$" ++ show i) [1 ..]) args
484+ pure $ JsNew (JsVar $ jsNameHiddenClass hc) args
435 else pure $ JsInt conId
485 else pure $ JsInt conId
436
486
437formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
487formConTest :: Name -> JsExpr -> State CGBodyState JsExpr
@@ -448,12 +498,21 @@ formProj :: Name -> JsExpr -> Int -> JsExpr
448formProj n v i =
498formProj n v i =
449 case specialCased n of
499 case specialCased n of
450 Just (ctor, test, proj) -> proj v i
500 Just (ctor, test, proj) -> proj v i
451− Nothing -> JsProp v (T.pack $ "$" ++ show i)
501+ Nothing -> JsProp v (dataPartName i)
452
502
453smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
503smartif :: JsExpr -> JsStmt -> Maybe JsStmt -> JsStmt
454smartif cond conseq (Just alt) = JsIf cond conseq (Just alt)
504smartif cond conseq (Just alt) = JsIf cond conseq (Just alt)
455smartif cond conseq Nothing = conseq
505smartif cond conseq Nothing = conseq
456
506
507+formConstTest :: JsExpr -> Const -> State CGBodyState JsExpr
508+formConstTest scrvar t = case t of
509+ BI _ -> do
510+ t' <- cgConst t
511+ cgOp' PTBool (LEq (ATInt ITBig)) [scrvar, t']
512+ _ -> do
513+ t' <- cgConst t
514+ pure $ JsBinOp "===" scrvar t'
515+
457cgIfTree :: BodyResTarget
516cgIfTree :: BodyResTarget
458 -> Text
517 -> Text
459 -> JsExpr
518 -> JsExpr
@@ -463,13 +522,7 @@ cgIfTree _ _ _ [] = pure Nothing
463cgIfTree rt resName scrvar ((LConstCase t exp):r) = do
522cgIfTree rt resName scrvar ((LConstCase t exp):r) = do
464 (d, v) <- cgBody (altsRT resName rt) exp
523 (d, v) <- cgBody (altsRT resName rt) exp
465 alternatives <- cgIfTree rt resName scrvar r
524 alternatives <- cgIfTree rt resName scrvar r
466− test <- case t of
525+ test <- formConstTest scrvar t
467− BI _ -> do
468− t' <- cgConst t
469− cgOp (LPlus (ATInt ITBig)) [scrvar, t']
470− _ -> do
471− t' <- cgConst t
472− pure $ JsBinOp "===" scrvar t'
473 pure $ Just $
526 pure $ Just $
474 smartif test (JsSeq (seqJs d) v) alternatives
527 smartif test (JsSeq (seqJs d) v) alternatives
475cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do
528cgIfTree rt resName scrvar ((LDefaultCase exp):r) = do
@@ -547,24 +600,24 @@ cgConst (B64 x) =
547cgConst x | isTypeConst x = pure $ JsInt 0
600cgConst x | isTypeConst x = pure $ JsInt 0
548cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
601cgConst x = error $ "Constant " ++ show x ++ " not compilable yet"
549
602
550−jsB2I :: JsExpr -> JsExpr
551−jsB2I x = JsForeign "%0 ? 1|0 : 0|0" [x]
552−
553cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
603cgOp :: PrimFn -> [JsExpr] -> State CGBodyState JsExpr
604+cgOp = cgOp' PTAny
605+
606+cgOp' :: JsPrimTy -> PrimFn -> [JsExpr] -> State CGBodyState JsExpr
554−cgOp LReadStr [_] =
607+cgOp' pt LReadStr [_] =
555 do
608 do
556 s <- get
609 s <- get
557 put $ s {usedRead = True}
610 put $ s {usedRead = True}
558 pure $ JsForeign (readStrTemplate $ conf s) []
611 pure $ JsForeign (readStrTemplate $ conf s) []
559−cgOp LWriteStr [_,str] =
612+cgOp' pt LWriteStr [_,str] =
560 do
613 do
561 s <- get
614 s <- get
562 put $ s {usedWrite = True}
615 put $ s {usedWrite = True}
563 pure $ JsForeign (writeStrTemplate $ conf s) [str]
616 pure $ JsForeign (writeStrTemplate $ conf s) [str]
564−cgOp (LExternal name) _ | name == sUN "prim__null" = pure JsNull
617+cgOp' pt (LExternal name) _ | name == sUN "prim__null" = pure JsNull
565−cgOp (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
618+cgOp' pt (LExternal name) [l,r] | name == sUN "prim__eqPtr" = pure $ JsBinOp "==" l r
566−cgOp op exps = case Map.lookup op primDB of
619+cgOp' pt op exps = case Map.lookup op primDB of
567 Just (useBigInt, pti, combinator) -> do
620 Just (useBigInt, pti, combinator) -> do
568 when useBigInt setUsedITBig
621 when useBigInt setUsedITBig
569− pure $ jsPrimCoerce pti PTAny $ combinator exps
622+ pure $ jsPrimCoerce pti pt $ combinator exps
570 Nothing -> error ("Operator " ++ show (op, exps) ++ " not implemented")
623 Nothing -> error ("Operator " ++ show (op, exps) ++ " not implemented")
src/IRTS/JavaScript/Name.hs+12
@@ -14,6 +14,9 @@ module IRTS.JavaScript.Name
14 , Partial(..)
14 , Partial(..)
15 , jsNamePartial
15 , jsNamePartial
16 , jsTailCallOptimName
16 , jsTailCallOptimName
17+ , HiddenClass(..)
18+ , jsNameHiddenClass
19+ , dataPartName
17 ) where
20 ) where
18
21
19import Data.Char
22import Data.Char
@@ -84,3 +87,12 @@ jsNamePartial (Partial n i j) = T.concat ["$partial_", T.pack $ show i, "_", T.p
84
87
85jsTailCallOptimName :: Text -> Text
88jsTailCallOptimName :: Text -> Text
86jsTailCallOptimName x = T.concat ["$tco$", x]
89jsTailCallOptimName x = T.concat ["$tco$", x]
90+
91+
92+data HiddenClass = HiddenClass Name Int Int deriving (Eq, Ord)
93+
94+jsNameHiddenClass :: HiddenClass -> Text
95+jsNameHiddenClass (HiddenClass n id arity) = T.concat ["$HC_", T.pack $ show arity, "_", T.pack $ show id,"$", jsName n]
96+
97+dataPartName :: Int -> Text
98+dataPartName i = T.pack $ "$" ++ show i
src/IRTS/JavaScript/Specialize.hs+6
@@ -52,6 +52,9 @@ constructorOptimizeDB =
52 Map.fromList
52 Map.fromList
53 [ item "Prelude.Bool" "True" (const $ JsBool True) trueTest cantProj
53 [ item "Prelude.Bool" "True" (const $ JsBool True) trueTest cantProj
54 , item "Prelude.Bool" "False" (const $ JsBool False) falseTest cantProj
54 , item "Prelude.Bool" "False" (const $ JsBool False) falseTest cantProj
55+ , item "Prelude.Interfaces" "LT" (const $ JsInt (0-1)) ltTest cantProj
56+ , item "Prelude.Interfaces" "EQ" (const $ JsInt 0) eqTest cantProj
57+ , item "Prelude.Interfaces" "GT" (const $ JsInt 1) gtTest cantProj
55 -- , item "Prelude.List" "::" cons fillList uncons
58 -- , item "Prelude.List" "::" cons fillList uncons
56 -- , item "Prelude.List" "Nil" nil emptyList cantProj
59 -- , item "Prelude.List" "Nil" nil emptyList cantProj
57 -- , item "Prelude.Maybe" "Just" (\[x] -> x) notNoneTest justProj
60 -- , item "Prelude.Maybe" "Just" (\[x] -> x) notNoneTest justProj
@@ -67,6 +70,9 @@ constructorOptimizeDB =
67 falseTest e = JsUniOp (T.pack "!") e
70 falseTest e = JsUniOp (T.pack "!") e
68 emptyList e = JsBinOp "===" (JsProp e "length") (JsInt 0)
71 emptyList e = JsBinOp "===" (JsProp e "length") (JsInt 0)
69 fillList e = JsBinOp ">" (JsProp e "length") (JsInt 0)
72 fillList e = JsBinOp ">" (JsProp e "length") (JsInt 0)
73+ ltTest e = JsBinOp "<" e (JsInt 0)
74+ eqTest e = JsBinOp "===" e (JsInt 0)
75+ gtTest e = JsBinOp ">" e (JsInt 0)
70 noneTest e = JsBinOp "===" e JsUndefined
76 noneTest e = JsBinOp "===" e JsUndefined
71 notNoneTest e = JsBinOp "!==" e JsUndefined
77 notNoneTest e = JsBinOp "!==" e JsUndefined
72 -- projections
78 -- projections