87dc670 · elk · git.iko.soy

18import qualified Reporting.Region as R

19

20

21−-- OPTIMIZE FOR TAIL CALLS

21+-- OPTIMIZE - turn a canonical module into a list of optimized defs

22

23optimize :: Module.CanonicalModule -> Module.Optimized

24optimize module_ =

30 flattenLets [] (Module.program (Module.body module_))

31 in

32 State.evalState

33− (concat <$> mapM (definition (Just home)) defs)

33+ (concat <$> mapM (optimizeDef (Just home)) defs)

34 (Env False 0)

35

36

69

70-- CONVERT DEFINITIONS

71

72−definition :: Maybe ModuleName.Canonical -> Can.Def -> Optimizer [Opt.Def]

72+optimizeDef :: Maybe ModuleName.Canonical -> Can.Def -> Optimizer [Opt.Def]

73−definition home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expression _) =

73+optimizeDef home (Can.Definition (Can.Facts deps) pattern@(A.A _ ptrn) expression _) =

74 let

75 (args, rawBody) =

76 Expr.collectLambdas expression

100 (P.Var name, []) ->

101

102 do hasTailCall <- State.gets _hasTailCall

103− body <- findTailCalls Nothing rawBody

103+ body <- optimizeExpr Nothing rawBody

104 setTailCall hasTailCall

105 return [ Opt.Def (Opt.Facts home deps) name body ]

106

107 (_, []) ->

108

109 do name <- freshName

110− optBody <- findTailCalls Nothing rawBody

110+ optBody <- optimizeExpr Nothing rawBody

111 let optDef = Opt.Def (Opt.Facts home deps) name optBody

112 return (optDef : patternToDefs home name pattern)

113

124 -> Optimizer ([String], Opt.Expr)

125optimizeFunction maybeName patterns givenBody =

126 do (argNames, body) <- M.foldM depatternArgs ([], givenBody) (reverse patterns)

127− optBody <- findTailCalls (makeContext argNames =<< maybeName) body

127+ optBody <- optimizeExpr (makeContext argNames =<< maybeName) body

128 return (argNames, optBody)

129

130

189 concat (zipWith (substitutions . Opt.DataAccess expr) [0..] patterns)

190

191

192−-- CONVERT EXPRESSIONS

192+-- OPTIMIZE EXPRESSIONS

193

194type Context = Maybe (String, Int, [String])

195

196

197+{-| This optimizer detects tail calls. The `Context` holds a function name,

198+function arity, and list of argument names. If a tail call is possible, the

199+`Context` will be filled in and we check any function we run into. If we go

200+down a route that cannot possibly have tail calls, we remove the context.

201+-}

197−findTailCalls :: Context -> Can.Expr -> Optimizer Opt.Expr

202+optimizeExpr :: Context -> Can.Expr -> Optimizer Opt.Expr

198−findTailCalls context annExpr@(A.A region expression) =

203+optimizeExpr context annExpr@(A.A region expression) =

199 let

204 let

200 keepLooking =

205 keepLooking =

201− findTailCalls context

206+ optimizeExpr context

202 -- this *might* find a tail call, use this when something is a potential

207 -- this *might* find a tail call, use this when something is a potential

203 -- tail call

208 -- tail call

204

209

205 justConvert =

210 justConvert =

206− findTailCalls Nothing

211+ optimizeExpr Nothing

207 -- this will never find tail calls, use this when you are working with

212 -- this will never find tail calls, use this when you are working with

208 -- expressions that cannot be turned into tail calls

213 -- expressions that cannot be turned into tail calls

209 in

214 in

262 <*> keepLooking finally

267 <*> keepLooking finally

263

268

264 Expr.Let defs body ->

269 Expr.Let defs body ->

265− do optDefs <- concat <$> T.traverse (definition Nothing) defs

270+ do optDefs <- concat <$> T.traverse (optimizeDef Nothing) defs

266 Opt.Let optDefs <$> keepLooking body

271 Opt.Let optDefs <$> keepLooking body

267

272

268 Expr.Case expr rawBranches ->

273 Expr.Case expr rawBranches ->

405 in

410 in

406 if op == forwardApply then

411 if op == forwardApply then

407

412

408− findTailCalls context (collect id left forwardApply binop)

413+ optimizeExpr context (collect id left forwardApply binop)

409

414

410 else if op == backwardApply then

415 else if op == backwardApply then

411

416

412− findTailCalls context (collect id right backwardApply binop)

417+ optimizeExpr context (collect id right backwardApply binop)

413

418

414 else if op == forwardCompose then

419 else if op == forwardCompose then

415

420

416 do var <- freshName

421 do var <- freshName

417 let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))

422 let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))

418 let body = collect makeRoot left forwardCompose binop

423 let body = collect makeRoot left forwardCompose binop

419− findTailCalls context (ann (Expr.Lambda (ann (P.Var var)) body))

424+ optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))

420

425

421 else if op == backwardCompose then

426 else if op == backwardCompose then

422

427

423 do var <- freshName

428 do var <- freshName

424 let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))

429 let makeRoot func = ann (Expr.App func (ann (Expr.Var (Var.local var))))

425 let body = collect makeRoot right backwardCompose binop

430 let body = collect makeRoot right backwardCompose binop

426− findTailCalls context (ann (Expr.Lambda (ann (P.Var var)) body))

431+ optimizeExpr context (ann (Expr.Lambda (ann (P.Var var)) body))

427

432

428 else if op == Var.Canonical Var.BuiltIn "::" then

433 else if op == Var.Canonical Var.BuiltIn "::" then

429

434

430− findTailCalls context (ann (Expr.Data "::" [ leftExpr, rightExpr ]))

435+ optimizeExpr context (ann (Expr.Data "::" [ leftExpr, rightExpr ]))

431

436

432 else

437 else

433

438

434 Opt.Binop op

439 Opt.Binop op

435− <$> findTailCalls Nothing leftExpr

440+ <$> optimizeExpr Nothing leftExpr

436− <*> findTailCalls Nothing rightExpr

441+ <*> optimizeExpr Nothing rightExpr

437

442

438

443

439-- left-associative ((x |> f) |> g)

444-- left-associative ((x |> f) |> g)