b9cc20e · elk · git.iko.soy

git.iko.soy/elk

Optimize out (::) (>>) (|>) (<|) (<<) in the optimization phase

This sets us up to detect when the last pattern in a pattern match has the form “_ -> Debug.crash <| …”

commitb9cc20ecb03078554d4ff3d0091bf26d84d4bfb7 authorEvan Czaplicki <info@elm-lang.org> dateFri 4 Sep 2015, 09:43 (11 years ago) parent93cd759

2 files changed+105−104

compare with master

unifiedsplit

src/Generate/JavaScript.hs+4−100 src/Optimize/TailCalls.hs+101−4

src/Generate/JavaScript.hs+4−100

@@ -344,70 +344,10 @@ binop

344344 -> Opt.Expr

345345 -> Opt.Expr

346346 -> State Int Code

347−binop func left right

348− | func == Var.Canonical Var.BuiltIn "::" =

349− generateCode (Data "::" [left,right])

350−

351− | func == forwardCompose =

352− compose (collectLeftAssoc forwardCompose left right)

353−

354− | func == backwardCompose =

355− compose (collectRightAssoc backwardCompose left right)

356−

357− | func == forwardApply =

358− pipe (collectLeftAssoc forwardApply left right)

359−

360− | func == backwardApply =

361− pipe (collectRightAssoc backwardApply left right)

362−

363− | otherwise =

364− do jsLeft <- generateJsExpr left

365− jsRight <- generateJsExpr right

366− jsExpr (makeExpr func jsLeft jsRight)

367−

368−

369−-- CONTROL FLOW OPERATOR HELPERS

370−

371−apply :: Expression () -> Expression () -> Expression ()

372−apply arg func =

373− func <| arg

374−

375−

376−compose :: [Opt.Expr] -> State Int Code

377−compose functions =

378− do jsFunctions <- mapM generateJsExpr functions

379− jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions

380−

381−

382−pipe :: [Opt.Expr] -> State Int Code

383−pipe expressions =

384− do (value:functions) <- mapM generateJsExpr expressions

385− jsExpr $ List.foldl' apply value functions

386−

387−

388−forwardCompose :: Var.Canonical

389−forwardCompose =

390− inBasics ">>"

391−

392−

393−backwardCompose :: Var.Canonical

394−backwardCompose =

395− inBasics "<<"

396−

397−

398−forwardApply :: Var.Canonical

399−forwardApply =

400− inBasics "|>"

401−

402−

403−backwardApply :: Var.Canonical

404−backwardApply =

405− inBasics "<|"

406−

407−

408−inBasics :: String -> Var.Canonical

409−inBasics name =

410− Var.inCore ["Basics"] name

347+binop func left right =

348+ do jsLeft <- generateJsExpr left

349+ jsRight <- generateJsExpr right

350+ jsExpr (makeExpr func jsLeft jsRight)

411351

412352

413353-- BINARY OPERATOR HELPERS

@@ -447,7 +387,6 @@ infixOps =

447387specialOps :: [(String, Expression () -> Expression () -> Expression ())]

448388specialOps =

449389 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

450− , (,) "|>" $ flip (<|)

451390 , (,) "==" $ \a b -> BuiltIn.eq a b

452391 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (BuiltIn.eq a b)

453392 , (,) "<" $ cmp OpLT 0

@@ -461,38 +400,3 @@ specialOps =

461400cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()

462401cmp op n a b =

463402 InfixExpr () op (BuiltIn.compare a b) (IntLit () n)

464−

465−

466−-- BINARY OPERATOR COLLECTORS

467−

468−-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff

469−collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

470−collectRightAssoc desiredOp left right =

471− collectRightAssocHelp desiredOp [left] right

472−

473−

474−collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

475−collectRightAssocHelp desiredOp exprList expr =

476− case expr of

477− Binop op left right | op == desiredOp ->

478− collectRightAssocHelp desiredOp (left : exprList) right

479−

480− _ ->

481− expr : exprList

482−

483−

484−-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff

485−collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]

486−collectLeftAssoc desiredOp left right =

487− collectLeftAssocHelp desiredOp [right] left

488−

489−

490−collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]

491−collectLeftAssocHelp desiredOp exprList expr =

492− case expr of

493− Binop op left right | op == desiredOp ->

494− collectLeftAssocHelp desiredOp (right : exprList) left

495−

496− _ ->

497− expr : exprList

498−

src/Optimize/TailCalls.hs+101−4

@@ -15,6 +15,7 @@ import qualified AST.Pattern as P

1515import qualified AST.Variable as Var

1616import qualified Optimize.Cases as Cases

1717import qualified Reporting.Annotation as A

18+import qualified Reporting.Region as R

1819

1920

2021-- OPTIMIZE FOR TAIL CALLS

@@ -194,7 +195,7 @@ type Context = Maybe (String, Int, [String])

194195

195196

196197findTailCalls :: Context -> Can.Expr -> Optimizer Opt.Expr

197−findTailCalls context annExpr@(A.A _ expression) =

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

198199 let

199200 keepLooking =

200201 findTailCalls context

@@ -223,9 +224,7 @@ findTailCalls context annExpr@(A.A _ expression) =

223224 <$> T.traverse justConvert elements

224225

225226 Expr.Binop op leftExpr rightExpr ->

226− Opt.Binop op

227− <$> justConvert leftExpr

228− <*> justConvert rightExpr

227+ optimizeBinop context region op leftExpr rightExpr

229228

230229 Expr.Lambda _ _ ->

231230 let

@@ -388,3 +387,101 @@ freshName =

388387 do (Env htc uid) <- State.get

389388 State.put (Env htc (uid + 1))

390389 return ("_p" ++ show uid)

390+

391+

392+-- OPTIMIZE BINOPS

393+

394+optimizeBinop

395+ :: Context

396+ -> R.Region

397+ -> Var.Canonical

398+ -> Can.Expr

399+ -> Can.Expr

400+ -> Optimizer Opt.Expr

401+optimizeBinop context region op leftExpr rightExpr =

402+ let

403+ ann = A.A region

404+ binop = ann (Expr.Binop op leftExpr rightExpr)

405+ in

406+ if op == forwardApply then

407+

408+ findTailCalls context (collect id left forwardApply binop)

409+

410+ else if op == backwardApply then

411+

412+ findTailCalls context (collect id right backwardApply binop)

413+

414+ else if op == forwardCompose then

415+

416+ do var <- freshName

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

418+ let body = collect makeRoot left forwardCompose binop

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

420+

421+ else if op == backwardCompose then

422+

423+ do var <- freshName

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

425+ let body = collect makeRoot right backwardCompose binop

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

427+

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

429+

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

431+

432+ else

433+

434+ Opt.Binop op

435+ <$> findTailCalls Nothing leftExpr

436+ <*> findTailCalls Nothing rightExpr

437+

438+

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

440+forwardApply :: Var.Canonical

441+forwardApply =

442+ Var.inCore ["Basics"] "|>"

443+

444+

445+-- right-associative (g <| (f <| x))

446+backwardApply :: Var.Canonical

447+backwardApply =

448+ Var.inCore ["Basics"] "<|"

449+

450+

451+-- left-associative ((f >> g) >> h)

452+forwardCompose :: Var.Canonical

453+forwardCompose =

454+ Var.inCore ["Basics"] ">>"

455+

456+

457+-- right-associative (h << (g << f))

458+backwardCompose :: Var.Canonical

459+backwardCompose =

460+ Var.inCore ["Basics"] "<<"

461+

462+

463+type Assoc =

464+ Can.Expr -> Can.Expr -> (Can.Expr, Can.Expr)

465+

466+

467+left :: Assoc

468+left =

469+ flip (,)

470+

471+

472+right :: Assoc

473+right =

474+ (,)

475+

476+

477+collect :: (Can.Expr -> Can.Expr) -> Assoc -> Var.Canonical -> Can.Expr -> Can.Expr

478+collect makeRoot assoc desiredOp annExpr@(A.A ann expr) =

479+ case expr of

480+ Expr.Binop op leftExpr rightExpr | op == desiredOp ->

481+ let

482+ (func, arg) = assoc leftExpr rightExpr

483+ in

484+ A.A ann (Expr.App func (collect makeRoot assoc desiredOp arg))

485+

486+ _ ->

487+ makeRoot annExpr