24f580d · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Remove a few more lambdas in Lang IR

24f580dEdwin Brady9 years ago

src/IRTS/Lang.hs+9−8

compare with master

unifiedsplit

@@ -15,7 +15,7 @@ import Idris.Core.TT

16import Control.Monad.State hiding (lift)

17import Data.Data (Data)

18−import Data.List

18+import Data.List

19import qualified Data.Map.Strict as Map

20import Data.Typeable (Typeable)

21import GHC.Generics (Generic)

@@ -141,7 +141,7 @@ addTags i ds = tag i ds []

141 tag i (x : as) acc = tag i as (x : acc)

142 tag i [] acc = (i, reverse acc)

143

144−data LiftState = LS (Maybe Name) Int [(Name, LDecl)]

144+data LiftState = LS (Maybe Name) Int [(Name, LDecl)]

145 (Map.Map ([Name], LExp) Name) -- map from args/expressions

146 -- to names, so we don't create the same function

147 -- multiple times

@@ -171,12 +171,12 @@ renameArgs args e

171 (map snd newargs, rename newargs e)

172

173addFn :: Name -> LDecl -> State LiftState ()

174−addFn fn d

174+addFn fn d

175 = do LS n i ds done <- get

176 put (LS n i ((fn, d) : ds) done)

177

178makeFn :: [Name] -> LExp -> State LiftState Name

179−makeFn args exp

179+makeFn args exp

180 = do fn <- getNextName

181 let (args', exp') = renameArgs args exp

182 LS n i ds done <- get

@@ -189,7 +189,7 @@ makeFn args exp

189 return fn

190

191liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

192−liftAll xs =

192+liftAll xs =

193 let (LS _ _ decls _) = execState (mapM_ liftDef xs) (LS Nothing 0 [] Map.empty) in

194 decls

195

@@ -222,6 +222,7 @@ lift env (LForce e) = do e' <- lift env e

222lift env (LLet n v e) = do v' <- lift env v

223 e' <- lift (env ++ [n]) e

224 return (LLet n v' e')

225+lift env (LLam args (LLam args' e)) = lift env (LLam (args ++ args') e)

225lift env (LLam args e) = do e' <- lift (env ++ args) e

226lift env (LLam args e) = do e' <- lift (env ++ args) e

226 let usedArgs = nub $ usedIn env e'

227 let usedArgs = nub $ usedIn env e'

227 fn <- makeFn (usedArgs ++ args) e'

228 fn <- makeFn (usedArgs ++ args) e'

@@ -363,15 +364,15 @@ lsubst n new (LCase t e alts) = let e' = lsubst n new e

363lsubst n new tm = tm

364lsubst n new tm = tm

364

365

365rename :: [(Name, Name)] -> LExp -> LExp

366rename :: [(Name, Name)] -> LExp -> LExp

366−rename ns tm@(LV x)

367+rename ns tm@(LV x)

367 = case lookup x ns of

368 = case lookup x ns of

368 Just n -> LV n

369 Just n -> LV n

369 _ -> tm

370 _ -> tm

370−rename ns (LApp t e args)

371+rename ns (LApp t e args)

371 = let e' = rename ns e

372 = let e' = rename ns e

372 args' = map (rename ns) args in

373 args' = map (rename ns) args in

373 LApp t e' args'

374 LApp t e' args'

374−rename ns (LLazyApp fn args)

375+rename ns (LLazyApp fn args)

375 = let args' = map (rename ns) args in

376 = let args' = map (rename ns) args in

376 LLazyApp fn args'

377 LLazyApp fn args'

377rename ns (LLazyExp e) = LLazyExp (rename ns e)

378rename ns (LLazyExp e) = LLazyExp (rename ns e)

src/IRTS/LangOpts.hs+46−25

@@ -36,9 +36,10 @@ doInline :: LDefs -> LDecl -> LDecl

36doInline defs d@(LConstructor _ _ _) = d

37doInline defs (LFun opts topn args exp)

38 = let inl = evalState (eval [] initEnv [topn] defs exp)

39− (length args)

39+ (length args)

40 -- do some case floating, which might arise as a result

41+ -- then, eta contract

41− res = caseFloats 10 inl in

42+ res = eta $ caseFloats 10 inl in

42 case res of

43 case res of

43 LLam args' body -> LFun opts topn (map snd initNames ++ args') body

44 LLam args' body -> LFun opts topn (map snd initNames ++ args') body

44 _ -> LFun opts topn (map snd initNames) res

45 _ -> LFun opts topn (map snd initNames) res

@@ -110,10 +111,10 @@ eval stk env rec defs (LCase ty e alts)

110 -- If they're all lambdas, bind the lambda at the top

111 -- If they're all lambdas, bind the lambda at the top

111 let prefix = getLams (map getRHS alts')

112 let prefix = getLams (map getRHS alts')

112 case prefix of

113 case prefix of

113− [] -> return $ LCase ty e' (replaceInAlts e' alts')

114+ [] -> return $ conOpt $ LCase ty e' (replaceInAlts e' alts')

114 args -> do alts_red <- mapM (dropArgs args) alts'

115 args -> do alts_red <- mapM (dropArgs args) alts'

115− return $ LLam args

116+ return $ LLam args

116− (LCase ty e' (replaceInAlts e' alts_red))

117+ (conOpt (LCase ty e' (replaceInAlts e' alts_red)))

117eval stk env rec defs (LOp f es)

118eval stk env rec defs (LOp f es)

118 = unload stk <$> LOp f <$> mapM (eval [] env rec defs) es

119 = unload stk <$> LOp f <$> mapM (eval [] env rec defs) es

119eval stk env rec defs (LForeign t s args)

120eval stk env rec defs (LForeign t s args)

@@ -128,7 +129,7 @@ eval stk env rec defs (LLam args sc)

128 [] -> eval stk' env' rec defs sc

129 [] -> eval stk' env' rec defs sc

129 as -> do ns' <- mapM (\n -> do n' <- nextN

130 as -> do ns' <- mapM (\n -> do n' <- nextN

130 return (n, n')) args'

131 return (n, n')) args'

131− LLam (map snd ns') <$>

132+ unload stk' <$> LLam (map snd ns') <$>

132 eval [] (map (\ (n, n') -> (n, LV n')) ns' ++ env')

133 eval [] (map (\ (n, n') -> (n, LV n')) ns' ++ env')

133 rec defs sc

134 rec defs sc

134eval stk env rec defs var@(LV n)

135eval stk env rec defs var@(LV n)

@@ -157,6 +158,11 @@ evalAlt stk env rec defs (LConstCase c e)

157evalAlt stk env rec defs (LDefaultCase e)

158evalAlt stk env rec defs (LDefaultCase e)

158 = LDefaultCase <$> eval stk env rec defs e

159 = LDefaultCase <$> eval stk env rec defs e

159

160

161+apply :: [LExp] -> [(Name, LExp)] -> [Name] -> LDefs -> LExp ->

162+ [Name] -> LExp -> State Int LExp

163+apply stk env rec defs var args body

164+ = eval stk env rec defs (LLam args body)

165+

160dropArgs :: [Name] -> LAlt -> State Int LAlt

166dropArgs :: [Name] -> LAlt -> State Int LAlt

161dropArgs as (LConCase i n es (LLam args rhs))

167dropArgs as (LConCase i n es (LLam args rhs))

162 = do let old = take (length as) args

168 = do let old = take (length as) args

@@ -173,6 +179,7 @@ dropArgs as (LDefaultCase (LLam args rhs))

173

179

174caseFloat :: LExp -> LExp

180caseFloat :: LExp -> LExp

175caseFloat (LApp tc e es) = LApp tc (caseFloat e) (map caseFloat es)

181caseFloat (LApp tc e es) = LApp tc (caseFloat e) (map caseFloat es)

182+caseFloat (LLazyExp e) = LLazyExp (caseFloat e)

176caseFloat (LForce e) = LForce (caseFloat e)

183caseFloat (LForce e) = LForce (caseFloat e)

177caseFloat (LCon up i n es) = LCon up i n (map caseFloat es)

184caseFloat (LCon up i n es) = LCon up i n (map caseFloat es)

178caseFloat (LOp f es) = LOp f (map caseFloat es)

185caseFloat (LOp f es) = LOp f (map caseFloat es)

@@ -180,7 +187,7 @@ caseFloat (LLam ns sc) = LLam ns (caseFloat sc)

180caseFloat (LLet v val sc) = LLet v (caseFloat val) (caseFloat sc)

187caseFloat (LLet v val sc) = LLet v (caseFloat val) (caseFloat sc)

181caseFloat (LCase _ (LCase ct exp alts) alts')

188caseFloat (LCase _ (LCase ct exp alts) alts')

182 | all conRHS alts || length alts == 1

189 | all conRHS alts || length alts == 1

183− = replaceInCase (LCase ct (caseFloat exp) (map (updateWith alts') alts))

190+ = conOpt $ replaceInCase (LCase ct (caseFloat exp) (map (updateWith alts') alts))

184 where

191 where

185 conRHS (LConCase _ _ _ (LCon _ _ _ _)) = True

192 conRHS (LConCase _ _ _ (LCon _ _ _ _)) = True

186 conRHS (LConstCase _ (LCon _ _ _ _)) = True

193 conRHS (LConstCase _ (LCon _ _ _ _)) = True

@@ -194,10 +201,19 @@ caseFloat (LCase _ (LCase ct exp alts) alts')

194 updateWith alts (LDefaultCase rhs) =

201 updateWith alts (LDefaultCase rhs) =

195 LDefaultCase (caseFloat (conOpt (LCase Shared (caseFloat rhs) alts)))

202 LDefaultCase (caseFloat (conOpt (LCase Shared (caseFloat rhs) alts)))

196

203

197− conOpt (LCase ct (LCon _ t n args) alts)

204+caseFloat (LCase ct exp alts')

198− = pickAlt n args alts

205+ = conOpt $ replaceInCase (LCase ct (caseFloat exp) (map cfAlt alts'))

199− conOpt tm = tm

206+ where

207+ cfAlt (LConCase i n es rhs) = LConCase i n es (caseFloat rhs)

208+ cfAlt (LConstCase c rhs) = LConstCase c (caseFloat rhs)

209+ cfAlt (LDefaultCase rhs) = LDefaultCase (caseFloat rhs)

210+caseFloat exp = exp

200

211

212+-- Case of constructor

213+conOpt :: LExp -> LExp

214+conOpt (LCase ct (LCon _ t n args) alts)

215+ = pickAlt n args alts

216+ where

201 pickAlt n args (LConCase i n' es rhs : as) | n == n'

217 pickAlt n args (LConCase i n' es rhs : as) | n == n'

202 = substAll (zip es args) rhs

218 = substAll (zip es args) rhs

203 pickAlt _ _ (LDefaultCase rhs : as) = rhs

219 pickAlt _ _ (LDefaultCase rhs : as) = rhs

@@ -206,14 +222,7 @@ caseFloat (LCase _ (LCase ct exp alts) alts')

206

222

207 substAll [] rhs = rhs

223 substAll [] rhs = rhs

208 substAll ((n, tm) : ss) rhs = lsubst n tm (substAll ss rhs)

224 substAll ((n, tm) : ss) rhs = lsubst n tm (substAll ss rhs)

209−

225+conOpt tm = tm

210−caseFloat (LCase ct exp alts')

211− = replaceInCase (LCase ct (caseFloat exp) (map cfAlt alts'))

212− where

213− cfAlt (LConCase i n es rhs) = LConCase i n es (caseFloat rhs)

214− cfAlt (LConstCase c rhs) = LConstCase c (caseFloat rhs)

215− cfAlt (LDefaultCase rhs) = LDefaultCase (caseFloat rhs)

216−caseFloat exp = exp

217

226

218replaceInCase :: LExp -> LExp

227replaceInCase :: LExp -> LExp

219replaceInCase (LCase ty e alts)

228replaceInCase (LCase ty e alts)

@@ -225,7 +234,7 @@ replaceInAlts exp alts = dropDups $ concatMap (replaceInAlt exp) alts

225

234

226-- Drop overlapping case (arising from case merging of overlapping

235-- Drop overlapping case (arising from case merging of overlapping

227-- patterns)

236-- patterns)

228−dropDups (alt@(LConCase _ i n ns) : alts)

237+dropDups (alt@(LConCase _ i n ns) : alts)

229 = alt : dropDups (filter (notTag i) alts)

238 = alt : dropDups (filter (notTag i) alts)

230 where

239 where

231 notTag i (LConCase _ j n ns) = i /= j

240 notTag i (LConCase _ j n ns) = i /= j

@@ -248,9 +257,9 @@ replaceInAlt exp@(LV var) (LDefaultCase (LCase ty (LV var') alts))

248replaceInAlt exp a = [a]

257replaceInAlt exp a = [a]

249

258

250replaceExp :: LExp -> LExp -> LExp -> LExp

259replaceExp :: LExp -> LExp -> LExp -> LExp

251−replaceExp (LCon _ t n args) new (LCon _ t' n' args')

260+replaceExp (LCon _ t n args) new (LCon _ t' n' args')

252 | n == n' && args == args' = new

261 | n == n' && args == args' = new

253−replaceExp (LCon _ t n args) new (LApp _ (LV n') args')

262+replaceExp (LCon _ t n args) new (LApp _ (LV n') args')

254 | n == n' && args == args' = new

263 | n == n' && args == args' = new

255replaceExp old new tm = tm

264replaceExp old new tm = tm

256

265

@@ -271,7 +280,19 @@ getLamPrefix as (LLam args tm : cs)

271 | otherwise = getLamPrefix as cs

280 | otherwise = getLamPrefix as cs

272getLamPrefix as (_ : cs) = []

281getLamPrefix as (_ : cs) = []

273

282

274−apply :: [LExp] -> [(Name, LExp)] -> [Name] -> LDefs -> LExp ->

283+-- eta contract ('\x -> f x' can just be compiled as 'f' when f is local)

275− [Name] -> LExp -> State Int LExp

284+eta :: LExp -> LExp

276−apply stk env rec defs var args body

285+eta (LApp tc a es) = LApp tc (eta a) (map eta es)

277− = eval stk env rec defs (LLam args body)

286+eta (LLazyApp n es) = LLazyApp n (map eta es)

287+eta (LLazyExp e) = LLazyExp (eta e)

288+eta (LForce e) = LForce (eta e)

289+eta (LLet n val sc) = LLet n (eta val) (eta sc)

290+eta (LLam args (LApp tc f args'))

291+ | args' == map LV args = eta f

292+eta (LLam args e) = LLam args (eta e)

293+eta (LProj e i) = LProj (eta e) i

294+eta (LCon a t n es) = LCon a t n (map eta es)

295+eta (LCase ct e alts) = LCase ct (eta e) (map (fmap eta) alts)

296+eta (LOp f es) = LOp f (map eta es)

297+eta tm = tm

298+