18fa741 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

removed unused constructors

18fa741Rui Barreiro9 years ago

src/IRTS/JavaScript/Codegen.hs+12−19

compare with master

unifiedsplit

@@ -83,8 +83,8 @@ codegenJs conf ci =

83 if optim then putStrLn "compiling width idris-js optimizations"

84 else putStrLn "compiling widthout idris-js optimizations"

85 else pure ()

86− let defs = addAlist (liftDecls ci) emptyContext

86+ let defs = Map.fromList $ liftDecls ci

87− let used = used_decls defs [sMN 0 "runMain"]

87+ let used = Map.elems $ used_defs defs [sMN 0 "runMain"]

88 used `deepseq` if debug then

89 do

90 putStrLn $ "Finished calculating used"

@@ -137,7 +137,7 @@ doPartials x =

137 in jsAst2Text $

138 JsFun (jsPartialName p) vars1 $ JsReturn $ JsCurryLambda vars2 (JsApp (jsName n) (map JsVar (vars1 ++ vars2)) )

139

140−doCodegen :: CGConf -> LDefs -> [LDecl] -> (Text, CGStats)

140+doCodegen :: CGConf -> Map Name LDecl -> [LDecl] -> (Text, CGStats)

141doCodegen conf defs decls =

142 let xs = map (doCodegenDecl conf defs) decls

143 groupCGStats x y = CGStats {usedWriteStr = usedWriteStr x || usedWriteStr y

@@ -147,7 +147,7 @@ doCodegen conf defs decls =

147 }

148 in (T.intercalate "\n" $ map fst xs, foldl' groupCGStats emptyStats (map snd xs) )

149

150−doCodegenDecl :: CGConf -> LDefs -> LDecl -> (Text, CGStats)

150+doCodegenDecl :: CGConf -> Map Name LDecl -> LDecl -> (Text, CGStats)

151doCodegenDecl conf defs (LFun _ n args def) =

152 let (ast, stats) = cgFun conf defs n args def

153 in (jsAst2Text $ ast, stats)

@@ -159,7 +159,7 @@ seqJs [] = JsEmpty

159seqJs (x:xs) = JsSeq x (seqJs xs)

160

161

162−data CGBodyState = CGBodyState { defs :: LDefs

162+data CGBodyState = CGBodyState { defs :: Map Name LDecl

163 , lastIntName :: Int

164 , currentFnNameAndArgs :: (Text, [Text])

165 , usedArgsTailCallOptim :: Set (Text, Text)

@@ -195,7 +195,7 @@ getConsId :: Name -> State CGBodyState Int

195getConsId n =

196 do

197 st <- get

198− case lookupCtxtExact n (defs st) of

198+ case Map.lookup n (defs st) of

199 Just (LConstructor _ conId _) -> pure conId

200 _ -> error $ "Internal JS Backend error " ++ showCG n ++ " is not a constructor."

201

@@ -203,7 +203,7 @@ getArgList :: Name -> State CGBodyState (Maybe [Name])

203getArgList n =

204 do

205 st <- get

206− case lookupCtxtExact n (defs st) of

206+ case Map.lookup n (defs st) of

207 Just (LFun _ _ a _) -> pure $ Just a

208 _ -> pure Nothing

209

@@ -224,7 +224,7 @@ replaceVarsByProj n d z =

224 Just i -> JsArrayProj (JsInt i) n

225 f x = x

226

227−cgFun :: CGConf -> LDefs -> Name -> [Name] -> LExp -> (JsAST, CGStats)

227+cgFun :: CGConf -> Map Name LDecl -> Name -> [Name] -> LExp -> (JsAST, CGStats)

228cgFun cnf dfs n args def =

229 let

230 fnName = jsName n

@@ -295,10 +295,9 @@ cgBody rt (LV (Glob n)) =

295 pure $ ([], addRT rt $ JsApp (jsName n) [])

296 Just a ->

297 do

298− --newNames <- getNewCGNames $ length a

299 let part = Partial n 0 (length a)

298 let part = Partial n 0 (length a)

300 addPartial part

299 addPartial part

301− pure ([], addRT rt $ JsApp (jsPartialName part) []) --JsCurryLambda newNames (JsApp (jsName n) (map JsVar newNames)))

300+ pure ([], addRT rt $ JsApp (jsPartialName part) [])

302 Nothing ->

301 Nothing ->

303 pure $ ([], addRT rt $ JsVar $ jsName n)

302 pure $ ([], addRT rt $ JsVar $ jsName n)

304cgBody rt (LApp tailcall (LV (Glob fn)) args) =

303cgBody rt (LApp tailcall (LV (Glob fn)) args) =

@@ -315,10 +314,6 @@ cgBody rt (LApp tailcall (LV (Glob fn)) args) =

315 modify (\x-> x {isTailRec = True})

314 modify (\x-> x {isTailRec = True})

316 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty

315 let ((y1,y2), y3) = tailCallOptimRefreshArgs (zip argN argVals) Set.empty

317 addUsedArgsTailCallOptim y3

316 addUsedArgsTailCallOptim y3

318− --vars <- getNewCGNames $ length argN --sequence $ map (\_->getNewCGName) argN

319− --let refreshArgs = JsSetVar "cgArgs2" (JsArray argVals)

320− --let calcs = map (\(n,v) -> JsDecVar n v) (zip vars argVals)

321− --let calcsToArgs = map (\(n,v) -> JsSetVar n (JsVar v)) (zip argN vars)

322 pure (preDecs, y1 `JsSeq` y2)

317 pure (preDecs, y1 `JsSeq` y2)

323 _ ->

318 _ ->

324 do

319 do

@@ -339,8 +334,7 @@ cgBody rt (LApp tailcall (LV (Glob fn)) args) =

339 do

334 do

340 let part = Partial fn lenArgs lenAgFn

335 let part = Partial fn lenArgs lenAgFn

341 addPartial part

336 addPartial part

342− --newNames <- getNewCGNames $ lenAgFn - lenArgs

343− pure (preDecs, addRT rt $ JsApp (jsPartialName part) argVals ) -- JsCurryLambda newNames (JsApp fname (argVals ++ (map JsVar newNames) ) ) )

337+ pure (preDecs, addRT rt $ JsApp (jsPartialName part) argVals )

344

338

345cgBody rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)

339cgBody rt (LForce (LLazyApp n args)) = cgBody rt (LApp False (LV (Glob n)) args)

346cgBody rt (LLazyApp n args) =

340cgBody rt (LLazyApp n args) =

@@ -431,7 +425,6 @@ cgAlts rt resName scrvar ((LConCase _ n args exp):r) =

431 (d, v) <- cgBody (altsRT resName rt) exp

425 (d, v) <- cgBody (altsRT resName rt) exp

432 (ar, def) <- cgAlts rt resName scrvar r

426 (ar, def) <- cgAlts rt resName scrvar r

433 conId <- getConsId n

427 conId <- getConsId n

434− -- let branchBody = JsSeq (conCaseToProjs 1 scrvar args) $ JsSeq (seqJs d) v

435 let replace = replaceVarsByProj scrvar (Map.fromList $ zip (map jsName args) [1..])

428 let replace = replaceVarsByProj scrvar (Map.fromList $ zip (map jsName args) [1..])

436 let branchBody = JsSeq (seqJs $ map replace d) (replace v)

429 let branchBody = JsSeq (seqJs $ map replace d) (replace v)

437 pure ((JsInt conId, branchBody) : ar, def)

430 pure ((JsInt conId, branchBody) : ar, def)

@@ -454,7 +447,7 @@ cgForeignArg (FApp (UN "JS_FnT") [_,FApp (UN "JS_Fn") [_,_, a, FApp (UN "JS_FnIO

454cgForeignArg (desc, _) =

447cgForeignArg (desc, _) =

455 do

448 do

456 st <- get

449 st <- get

457− error $ "Foreign arg type " ++ show desc ++ " not supported yet. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)

450+ error $ "Foreign arg type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)

458

451

459cgForeignRes :: FDesc -> JsAST -> State CGBodyState JsAST

452cgForeignRes :: FDesc -> JsAST -> State CGBodyState JsAST

460cgForeignRes (FApp (UN "JS_IntT") _) x = pure x

453cgForeignRes (FApp (UN "JS_IntT") _) x = pure x

@@ -466,7 +459,7 @@ cgForeignRes (FCon (UN "JS_Float")) x = pure x

466cgForeignRes desc val =

459cgForeignRes desc val =

467 do

460 do

468 st <- get

461 st <- get

469− error $ "Foreign return type " ++ show desc ++ " not supported yet. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)

462+ error $ "Foreign return type " ++ show desc ++ " not supported. While generating function " ++ (show $ fst $ currentFnNameAndArgs st)

470

463

471setUsedITBig :: State CGBodyState ()

464setUsedITBig :: State CGBodyState ()

472setUsedITBig = modify (\s -> s {usedITBig = True})

465setUsedITBig = modify (\s -> s {usedITBig = True})

src/IRTS/JavaScript/LangTransforms.hs+27−13

@@ -7,7 +7,7 @@ Maintainer : The Idris Community.

7-}

8{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, OverloadedStrings, DeriveGeneric, DeriveAnyClass, FlexibleInstances #-}

10−module IRTS.JavaScript.LangTransforms( used_decls

10+module IRTS.JavaScript.LangTransforms( used_defs

11 ) where

@@ -81,31 +81,45 @@ mapMapListKeys :: Ord k => (a->a) -> [k] -> Map k a -> Map k a

81mapMapListKeys _ [] x = x

82mapMapListKeys f (t:r) x = mapMapListKeys f r $ Map.adjust f t x

84−memberCtx :: Name -> Ctxt a -> Bool

85−memberCtx n ctx =

86− case lookupCtxtExact n ctx of

87− Nothing -> False

88− Just _ -> True

90−

91−extract_globs :: LDefs -> LDecl -> [Name]

85+extract_globs :: Map Name LDecl -> LDecl -> [Name]

92extract_globs defs (LConstructor _ _ _) = []

86extract_globs defs (LConstructor _ _ _) = []

93extract_globs defs (LFun _ _ _ e) =

87extract_globs defs (LFun _ _ _ e) =

94 let f (LV (Glob x)) = Just x

88 let f (LV (Glob x)) = Just x

95 f (LLazyApp x _) = Just x

89 f (LLazyApp x _) = Just x

96 f _ = Nothing

90 f _ = Nothing

97− in [x | Just x <- map f $ universe e, memberCtx x defs]

91+ in [x | Just x <- map f $ universe e, Map.member x defs]

99−used_functions :: LDefs -> Set Name -> [Name] -> [Name]

93+used_functions :: Map Name LDecl -> Set Name -> [Name] -> [Name]

100used_functions _ _ [] = []

94used_functions _ _ [] = []

101used_functions alldefs done names =

95used_functions alldefs done names =

102− let decls = catMaybes $ map (\x -> lookupCtxtExact x alldefs) names

96+ let decls = catMaybes $ map (\x -> Map.lookup x alldefs) names

103 used_names = (nub $ concat $ map (extract_globs alldefs) decls) \\ names

97 used_names = (nub $ concat $ map (extract_globs alldefs) decls) \\ names

104 new_names = filter (\x -> not $ Set.member x done) used_names

98 new_names = filter (\x -> not $ Set.member x done) used_names

105 in used_names ++ used_functions alldefs (Set.union done $ Set.fromList new_names) new_names

99 in used_names ++ used_functions alldefs (Set.union done $ Set.fromList new_names) new_names

106

100

107

101

108−used_decls :: LDefs -> [Name] -> [LDecl]

102+used_decls :: Map Name LDecl -> [Name] -> Map Name LDecl

109used_decls dcls start =

103used_decls dcls start =

110 let used = reverse $ start ++ used_functions dcls (Set.fromList start) start

104 let used = reverse $ start ++ used_functions dcls (Set.fromList start) start

111− in catMaybes $ map (\x -> lookupCtxtExact x dcls) used

105+ in restrictKeys dcls (Set.fromList used) --catMaybes $ map (\x -> Map.lookup x dcls) used

106+

107+getUsedConstructors :: Map Name LDecl -> Set Name

108+getUsedConstructors x = Set.fromList [ n | LCon _ _ n _ <- universeBi x]

109+

110+remove_unused_branches :: Set Name -> Map Name LDecl -> Map Name LDecl

111+remove_unused_branches used x =

112+ transformBi f x

113+ where

114+ f :: [LAlt] -> [LAlt]

115+ f ((LConCase x n y z):r) =

116+ if Set.member n used then ((LConCase x n y z):r)

117+ else r

118+ f x = x

119+

120+used_defs :: Map Name LDecl -> [Name] -> Map Name LDecl

121+used_defs dcls start =

122+ let used = used_decls dcls start

123+ remCons = remove_unused_branches (getUsedConstructors used) used

124+ in if Map.keys remCons == Map.keys dcls then remCons

125+ else used_defs remCons start