Optimize pass-through cases

CONTRIBUTORS.md

@@ -56,6 +56,7 @@ This file lists the contributors to the PureScript compiler project, and the ter
 - [@philopon](https://github.com/philopon) (Hirotomo Moriwaki) - My existing contributions and all future contributions until further notice are Copyright Hirotomo Moriwaki, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
 - [@pseudonom](https://github.com/pseudonom) (Eric Easley) My existing contributions and all future contributions until further notice are Copyright Eric Easley, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
 - [@puffnfresh](https://github.com/puffnfresh) (Brian McKenna) All contributions I made during June 2015 were during employment at [SlamData, Inc.](#companies) who owns the copyright. I assign copyright of all my personal contributions before June 2015 to the owners of the PureScript compiler.
+- [@rightfold](https://github.com/rightfold) (rightfold) - My existing contributions and all future contributions until further notice are Copyright rightfold, and are licensed to the owners and users of the PureScript compiler project under the terms of the [BSD 3-clause license](https://opensource.org/licenses/BSD-3-Clause).
 - [@robdaemon](https://github.com/robdaemon) (Robert Roland) My existing contributions and all future contributions until further notice are Copyright Robert Roland, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
 - [@RossMeikleham](https://github.com/RossMeikleham) (Ross Meikleham) My existing contributions and all future contributions until further notice are Copyright Ross Meikleham, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).
 - [@sebastiaanvisser](https://github.com/sebastiaanvisser) (Sebastiaan Visser) - My existing contributions and all future contributions until further notice are Copyright Sebastiaan Visser, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license.

examples/passing/PassThroughCases.js

@@ -0,0 +1,9 @@
+'use strict';
+
+exports.refEq = function(a) {
+    return function(b) {
+        return function() {
+            return a === b;
+        };
+    };
+};

examples/passing/PassThroughCases.purs

@@ -0,0 +1,86 @@
+module Main where
+
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+import Data.Maybe as Maybe
+import Prelude
+import Test.Assert (ASSERT, assert)
+
+foreign import refEq :: forall eff a b. a -> b -> Eff eff Boolean
+
+data T = C | D Int | E Int Int | X
+
+data Maybe a = Just a | Nothing
+
+main :: forall e. Eff (console :: CONSOLE, assert :: ASSERT | e) Unit
+main = do
+  let c = C
+  let d = D 1
+  let e = E 1 2
+  let nothing = Maybe.Nothing
+  let just = Maybe.Just 1
+
+  aEq <- refEq c (case c of
+                    C -> C
+                    _ -> X)
+  assert (aEq)
+
+  dEq1 <- refEq d (case d of
+                     D x -> D x
+                     _ -> X)
+  assert (dEq1)
+
+  dEq2 <- refEq d (case d of
+                     D x -> D 2
+                     _ -> X)
+  assert (not dEq2)
+
+  eEq1 <- refEq e (case e of
+                     E x y -> E x y
+                     _ -> X)
+  assert (eEq1)
+
+  eEq2 <- refEq e (case e of
+                     E x y -> E y x
+                     _ -> X)
+  assert (not eEq2)
+
+  nothingEq <- refEq nothing (case nothing of
+                                Maybe.Nothing -> Maybe.Nothing
+                                _ -> Maybe.Just 1)
+  assert (nothingEq)
+
+  justEq1 <- refEq just (case just of
+                           Maybe.Just x -> Maybe.Just x
+                           _ -> Maybe.Nothing)
+  assert (justEq1)
+
+  justEq2 <- refEq just (case just of
+                           Maybe.Just x -> Maybe.Just 2
+                           _ -> Maybe.Nothing)
+  assert (not justEq2)
+
+  let maybe = case (case just of
+                      Maybe.Just maybe -> Maybe.Just Maybe.maybe
+                      _ -> Maybe.Nothing) of
+                Maybe.Just m -> m
+                _ -> \x f m -> Maybe.maybe x f m
+  dangerousEq1 <- refEq Maybe.maybe maybe
+  assert (dangerousEq1)
+
+  dangerousEq2 <- refEq just (case just of
+                                Maybe.Just x -> Just x
+                                _ -> Nothing)
+  assert (not dangerousEq2)
+
+  nestedEq <- refEq just (case just of
+                            Maybe.Just x -> let j = Maybe.Just x in j
+                            _ -> Maybe.Nothing)
+  assert (nestedEq)
+
+  shadowEq <- refEq just (case just of
+                            Maybe.Just x -> let x = 2 in Maybe.Just x
+                            _ -> Maybe.Nothing)
+  assert (not shadowEq)
+
+  log "Done"

purescript.cabal

@@ -173,6 +173,8 @@ library
                      Language.PureScript.CoreFn.Expr
                      Language.PureScript.CoreFn.Meta
                      Language.PureScript.CoreFn.Module
+                     Language.PureScript.CoreFn.Optimizer
+                     Language.PureScript.CoreFn.Optimizer.PassThroughCases
                      Language.PureScript.CoreFn.Traversals
                      Language.PureScript.Comments
                      Language.PureScript.Environment

src/Language/PureScript/CodeGen/JS.hs

@@ -24,8 +24,9 @@ import qualified Data.Traversable as T
 import Language.PureScript.AST.SourcePos
 import Language.PureScript.CodeGen.JS.AST as AST
 import Language.PureScript.CodeGen.JS.Common as Common
+import Language.PureScript.Names
 import Language.PureScript.CodeGen.JS.Optimizer
-import Language.PureScript.CoreFn
+import Language.PureScript.CoreFn hiding (optimize)
 import Language.PureScript.Crash
 import Language.PureScript.Errors
 import Language.PureScript.Names
@@ -214,7 +215,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
     ret <- valueToJs val
     return $ JSFunction Nothing Nothing [identToJs arg] (JSBlock Nothing [JSReturn Nothing ret])
   valueToJs' e@App{} = do
-    let (f, args) = unApp e []
+    let (f, args) = unApp e
     args' <- mapM valueToJs args
     case f of
       Var (_, _, _, Just IsNewtype) _ -> return (head args')
@@ -223,10 +224,6 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
       Var (_, _, _, Just IsTypeClassConstructor) name ->
         return $ JSUnary Nothing JSNew $ JSApp Nothing (qualifiedToJS id name) args'
       _ -> flip (foldl (\fn a -> JSApp Nothing fn [a])) args' <$> valueToJs f
-    where
-    unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
-    unApp (App _ val arg) args = unApp val (arg : args)
-    unApp other args = (other, args)
   valueToJs' (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
     return $ if mn' == mn
              then foreignIdent ident

src/Language/PureScript/CoreFn.hs

@@ -12,4 +12,5 @@ import Language.PureScript.CoreFn.Desugar as C
 import Language.PureScript.CoreFn.Expr as C
 import Language.PureScript.CoreFn.Meta as C
 import Language.PureScript.CoreFn.Module as C
+import Language.PureScript.CoreFn.Optimizer as C
 import Language.PureScript.CoreFn.Traversals as C

src/Language/PureScript/CoreFn/Expr.hs

@@ -119,3 +119,13 @@ modifyAnn f (App a b c)           = App (f a) b c
 modifyAnn f (Var a b)             = Var (f a) b
 modifyAnn f (Case a b c)          = Case (f a) b c
 modifyAnn f (Let a b c)           = Let (f a) b c
+
+
+-- |
+-- Extract the callee and arguments of a call.
+--
+unApp :: Expr a -> (Expr a, [Expr a])
+unApp e = go e []
+  where
+  go (App _ val arg) args = go val (arg : args)
+  go other args = (other, args)

src/Language/PureScript/CoreFn/Optimizer.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Language.PureScript.CoreFn.Optimizer (optimize) where
+
+import Control.Monad.Reader (asks, MonadReader)
+import Control.Monad.Supply.Class (MonadSupply)
+import Language.PureScript.CoreFn.Ann (Ann)
+import Language.PureScript.CoreFn.Module (Module)
+import Language.PureScript.CoreFn.Optimizer.PassThroughCases
+import Language.PureScript.Options (Options, optionsNoOptimizations)
+import Prelude
+
+-- |
+-- Apply a series of optimizer passes to CoreFn
+--
+optimize :: (Monad m, MonadReader Options m, MonadSupply m)
+         => Module Ann
+         -> m (Module Ann)
+optimize m = do
+  noOpt <- asks optionsNoOptimizations
+  if noOpt then return m else optimize' m
+
+optimize' :: (Monad m, MonadSupply m) => Module Ann -> m (Module Ann)
+optimize' = go passes
+  where passes = [ passThroughCases
+                 ]
+        go [] m = return m
+        go (p : ps) m = p m >>= go ps

src/Language/PureScript/CoreFn/Optimizer/PassThroughCases.hs

@@ -0,0 +1,89 @@
+-- |
+-- Optimizer step for simplifying "pass-through cases", for example:
+--
+-- > f (C x) = C x
+-- > -- becomes
+-- > f c@(C _) = c
+--
+-- This optimization is safe; PureScript provides no way to compare the memory
+-- location of values, so data constructor calls can be optimized out freely.
+--
+-- This optimization must be performed after type checking, because it may
+-- change the code in such a way that the result is ill-typed. This optimization
+-- is performed before code generation, because it is common to all back-ends.
+--
+
+module Language.PureScript.CoreFn.Optimizer.PassThroughCases
+  ( passThroughCases
+  ) where
+
+import Control.Monad.Supply.Class (freshName, MonadSupply)
+import Language.PureScript.CoreFn.Ann (Ann)
+import Language.PureScript.CoreFn.Binders (Binder(..))
+import Language.PureScript.CoreFn.Expr
+import Language.PureScript.CoreFn.Meta (Meta(IsConstructor))
+import Language.PureScript.CoreFn.Module (Module, moduleDecls)
+import Language.PureScript.CoreFn.Traversals (everywhereOnValues, everywhereOnValuesM)
+import Language.PureScript.Names
+import Prelude
+
+passThroughCases :: (Monad m, MonadSupply m) => Module Ann -> m (Module Ann)
+passThroughCases m = (\mds -> m { moduleDecls = mds }) <$> onBinds (moduleDecls m)
+  where
+  onBinds :: (Monad m, MonadSupply m) => [Bind Ann] -> m [Bind Ann]
+  onBinds = let (f, _, _) = everywhereOnValuesM return onExpr return
+             in mapM f
+
+  onExpr :: (Monad m, MonadSupply m) => Expr Ann -> m (Expr Ann)
+  onExpr (Case ss ts cs) = Case ss ts <$> mapM onCaseAlternative cs
+  onExpr e = return e
+
+  onCaseAlternative :: (Monad m, MonadSupply m) => CaseAlternative Ann -> m (CaseAlternative Ann)
+  onCaseAlternative (CaseAlternative [bndr@(ConstructorBinder bndrAnn _ ctor prms)] (Right body)) = do
+    v <- Ident <$> freshName
+    let (_, comments, type_, _) = bndrAnn
+        vAnn = (Nothing, comments, type_, Nothing)
+        (_, f, _) = everywhereOnValues id (replaceReconstructions v vAnn ctor prms) id
+    return $ CaseAlternative [NamedBinder bndrAnn v bndr] (Right $ f body)
+  onCaseAlternative a = return a
+
+  replaceReconstructions :: Ident
+                         -> Ann
+                         -> Qualified (ProperName 'ConstructorName)
+                         -> [Binder Ann]
+                         -> Expr Ann
+                         -> Expr Ann
+  replaceReconstructions v vAnn ctor prms expr
+    | isReconstruction ctor prms expr = Var vAnn (Qualified Nothing $ v)
+    | otherwise = expr
+
+  isReconstruction :: Qualified (ProperName 'ConstructorName)
+                   -> [Binder Ann]
+                   -> Expr Ann
+                   -> Bool
+  isReconstruction (Qualified (Just ctorModule) ctor) prms body =
+    case dissectConstruction body of
+      Just (Qualified (Just ctorModule') ctor', args) ->
+        ctorModule == ctorModule'
+        && Ident (runProperName ctor) == ctor'
+        && length prms == length args
+        && all isBinderArg (prms `zip` args)
+      _ -> False
+    where isBinderArg (VarBinder _ i, Var _ (Qualified Nothing i')) = i == i'
+          isBinderArg _ = False
+  isReconstruction _ _ _ = False
+
+
+-- |
+-- Return the constructor and arguments from what looks like a data constructor
+-- call.
+--
+dissectConstruction :: Expr Ann -> Maybe (Qualified Ident, [Expr Ann])
+dissectConstruction e =
+  case unApp e of
+    (Var ann c, args) | isConstructor ann -> Just (c, args)
+    _ -> Nothing
+  where
+  isConstructor :: Ann -> Bool
+  isConstructor (_, _, _, Just (IsConstructor _ _)) = True
+  isConstructor _ = False

src/Language/PureScript/CoreFn/Traversals.hs

@@ -1,48 +1,69 @@
+{-# LANGUAGE TupleSections #-}
 -- |
 -- CoreFn traversal helpers
 --
 module Language.PureScript.CoreFn.Traversals where
 
-import Prelude.Compat
-
-import Control.Arrow (second, (***), (+++))
-
+import Data.Functor.Identity (runIdentity)
 import Language.PureScript.AST.Literals
 import Language.PureScript.CoreFn.Binders
 import Language.PureScript.CoreFn.Expr
+import Language.PureScript.Traversals (eitherM, pairM)
+import Prelude.Compat
 
 everywhereOnValues :: (Bind a -> Bind a) ->
                       (Expr a -> Expr a) ->
                       (Binder a -> Binder a) ->
                       (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
-everywhereOnValues f g h = (f', g', h')
+everywhereOnValues f g h =
+  let (f', g', h') = everywhereOnValuesM (return . f) (return . g) (return . h)
+   in (runIdentity . f', runIdentity . g', runIdentity . h')
+
+everywhereOnValuesM :: (Monad m) =>
+                       (Bind a -> m (Bind a)) ->
+                       (Expr a -> m (Expr a)) ->
+                       (Binder a -> m (Binder a)) ->
+                       (Bind a -> m (Bind a), Expr a -> m (Expr a), Binder a -> m (Binder a))
+everywhereOnValuesM f g h = (f', g', h')
   where
-  f' (NonRec a name e) = f (NonRec a name (g' e))
-  f' (Rec es) = f (Rec (map (second g') es))
+  f' (NonRec a name e) = f . NonRec a name =<< g' e
+  f' (Rec es) = f . Rec =<< mapM (\(b, e) -> (b,) <$> g' e) es
 
-  g' (Literal ann e) = g (Literal ann (handleLiteral g' e))
-  g' (Accessor ann prop e) = g (Accessor ann prop (g' e))
-  g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs))
-  g' (Abs ann name e) = g (Abs ann name (g' e))
-  g' (App ann v1 v2) = g (App ann (g' v1) (g' v2))
-  g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts))
-  g' (Let ann ds e) = g (Let ann (map f' ds) (g' e))
+  g' (Literal ann e) = g . Literal ann =<< handleLiteral g' e
+  g' (Accessor ann prop e) = g . Accessor ann prop =<< g' e
+  g' (ObjectUpdate ann obj vs) = do
+    obj' <- g' obj
+    vs' <- mapM (mapM g') vs
+    g (ObjectUpdate ann obj' vs')
+  g' (Abs ann name e) = g . Abs ann name =<< g' e
+  g' (App ann v1 v2) = do
+    v1' <- g' v1
+    v2' <- g' v2
+    g (App ann v1' v2')
+  g' (Case ann vs alts) = do
+    vs' <- mapM g' vs
+    alts' <- mapM handleCaseAlternative alts
+    g (Case ann vs' alts')
+  g' (Let ann ds e) = do
+    ds' <- mapM f' ds
+    e' <- g' e
+    g (Let ann ds' e')
   g' e = g e
 
-  h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))
-  h' (NamedBinder a name b) = h (NamedBinder a name (h' b))
-  h' (ConstructorBinder a q1 q2 bs) = h (ConstructorBinder a q1 q2 (map h' bs))
+  h' (LiteralBinder a b) = h . LiteralBinder a =<< handleLiteral h' b
+  h' (NamedBinder a name b) = h . NamedBinder a name =<< h' b
+  h' (ConstructorBinder a q1 q2 bs) = h . ConstructorBinder a q1 q2 =<< mapM h' bs
   h' b = h b
 
   handleCaseAlternative ca =
-    ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
-       , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
-       }
+    CaseAlternative
+      <$> traverse h' (caseAlternativeBinders ca)
+      <*> eitherM (traverse (pairM g' g')) g' (caseAlternativeResult ca)
 
-  handleLiteral :: (a -> a) -> Literal a -> Literal a
-  handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls)
-  handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls)
-  handleLiteral _ other = other
+  handleLiteral :: (Monad m) => (a -> m a) -> Literal a -> m (Literal a)
+  handleLiteral i (ArrayLiteral ls) = ArrayLiteral <$> mapM i ls
+  handleLiteral i (ObjectLiteral ls) = ObjectLiteral <$> mapM (mapM i) ls
+  handleLiteral _ other = return other
 
 everythingOnValues :: (r -> r -> r) ->
                       (Bind a -> r) ->