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

git.iko.soy/Idris-dev

removed unused constructors

commit18fa74106c0dac55046e04fe950625a78df751fa authorRui Barreiro <rui.barreiro@gmail.com> dateFri 5 May 2017, 19:19 (9 years ago) parentda46fd6

2 files changed+39−32

compare with master

unifiedsplit

src/IRTS/JavaScript/Codegen.hs+12−19 src/IRTS/JavaScript/LangTransforms.hs+27−13

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

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

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

8484 else putStrLn "compiling widthout idris-js optimizations"

8585 else pure ()

86− let defs = addAlist (liftDecls ci) emptyContext

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

86+ let defs = Map.fromList $ liftDecls ci

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

8888 used `deepseq` if debug then

8989 do

9090 putStrLn $ "Finished calculating used"

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

137137 in jsAst2Text $

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

139139

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

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

141141doCodegen conf defs decls =

142142 let xs = map (doCodegenDecl conf defs) decls

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

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

147147 }

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

149149

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

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

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

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

153153 in (jsAst2Text $ ast, stats)

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

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

160160

161161

162−data CGBodyState = CGBodyState { defs :: LDefs

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

163163 , lastIntName :: Int

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

165165 , usedArgsTailCallOptim :: Set (Text, Text)

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

195195getConsId n =

196196 do

197197 st <- get

198− case lookupCtxtExact n (defs st) of

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

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

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

201201

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

203203getArgList n =

204204 do

205205 st <- get

206− case lookupCtxtExact n (defs st) of

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

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

208208 _ -> pure Nothing

209209

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

224224 Just i -> JsArrayProj (JsInt i) n

225225 f x = x

226226

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

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

228228cgFun cnf dfs n args def =

229229 let

230230 fnName = jsName n

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

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

296296 Just a ->

297297 do

298− --newNames <- getNewCGNames $ length a

299298 let part = Partial n 0 (length a)

300299 addPartial part

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

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

302301 Nothing ->

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

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

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

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

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

317316 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)

322317 pure (preDecs, y1 `JsSeq` y2)

323318 _ ->

324319 do

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

339334 do

340335 let part = Partial fn lenArgs lenAgFn

341336 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 )

344338

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

346340cgBody rt (LLazyApp n args) =

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

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

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

433427 conId <- getConsId n

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

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

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

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

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

454447cgForeignArg (desc, _) =

455448 do

456449 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)

458451

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

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

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

466459cgForeignRes desc val =

467460 do

468461 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)

470463

471464setUsedITBig :: State CGBodyState ()

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

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

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

77-}

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

10−module IRTS.JavaScript.LangTransforms( used_decls

10+module IRTS.JavaScript.LangTransforms( used_defs

1111 ) where

1212

1313

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

8181mapMapListKeys _ [] x = x

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

8383

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

85−memberCtx n ctx =

86− case lookupCtxtExact n ctx of

87− Nothing -> False

88− Just _ -> True

8984

90−

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

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

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

9387extract_globs defs (LFun _ _ _ e) =

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

9589 f (LLazyApp x _) = Just x

9690 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]

9892

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

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

10094used_functions _ _ [] = []

10195used_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

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

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

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

106100

107101

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

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

109103used_decls dcls start =

110104 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