Merge remote-tracking branch 'origin/master' into migrate-travis-ci

Conflicts:
	.travis.yml

Author: avh4

.travis.yml

@@ -1,45 +1,18 @@
 sudo: false
 
-matrix:
-  include:
-    - env: GHC_VERSION=7.10.1
-      addons:
-        apt:
-          sources:
-          - hvr-ghc
-          packages:
-          - ghc-7.10.1
-          - cabal-install-1.22
-          - happy
-          - alex
-      before_install:
-      - export PATH=/opt/ghc/7.10.1/bin:/opt/cabal/1.22/bin:$PATH
-    - env: GHC_VERSION=7.8.3
-      addons:
-        apt:
-          sources:
-          - hvr-ghc
-          packages:
-          - ghc-7.8.3
-          - cabal-install-1.18
-          - happy-1.19.4
-          - alex-3.1.3
-      before_install:
-      - export PATH=/opt/ghc/7.8.3/bin:/opt/cabal/1.18/bin:$PATH
-      - export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:$PATH
-    - env: GHC_VERSION=7.6.3
-      addons:
-        apt:
-          sources:
-          - hvr-ghc
-          packages:
-          - ghc-7.6.3
-          - cabal-install-1.18
-          - happy-1.19.4
-          - alex-3.1.3
-      before_install:
-      - export PATH=/opt/ghc/7.6.3/bin:/opt/cabal/1.18/bin:$PATH
-      - export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.4/bin:$PATH
+addons:
+  apt:
+    sources:
+    - hvr-ghc
+    packages:
+    - ghc-7.10.1
+    - cabal-install-1.22
+    - happy
+    - alex
+
+
+before_install:
+- export PATH=/opt/ghc/7.10.1/bin:/opt/cabal/1.22/bin:$PATH
 
 
 install:

src/AST/Expression/General.hs

@@ -67,7 +67,7 @@ data PortImpl expr tipe
     = In String (Type.Port tipe)
     | Out String expr (Type.Port tipe)
     | Task String expr (Type.Port tipe)
-    deriving (Show)
+    deriving (Eq, Show)
 
 
 portName :: PortImpl expr tipe -> String

src/AST/Expression/Optimized.hs

@@ -19,12 +19,14 @@ import qualified Reporting.Region as R
 data Def
     = Def Facts String Expr
     | TailDef Facts String [String] Expr
+    deriving (Eq)
 
 
 data Facts = Facts
     { home :: Maybe ModuleName.Canonical
     , dependencies :: [Var.TopLevel]
     }
+    deriving (Eq)
 
 
 dummyFacts :: Facts
@@ -54,14 +56,17 @@ data Expr
     | Port (General.PortImpl Expr Type.Canonical)
     | GLShader String String Literal.GLShaderTipe
     | Crash R.Region (Maybe String)
+    deriving (Eq)
 
 
 data Jump
     = Inline Branch
     | Jump Int
+    deriving (Eq)
 
 
 data Branch = Branch
     { _substitutions :: [(String, DT.Path)]
     , _branch :: Expr
-    }
+    }
+    deriving (Eq)

src/AST/Literal.hs

@@ -39,7 +39,7 @@ data GLTipe
     | V4
     | M4
     | Texture
-    deriving (Show)
+    deriving (Eq, Show)
 
 
 glTipeName :: GLTipe -> String
@@ -59,4 +59,4 @@ data GLShaderTipe = GLShaderTipe
     , uniform :: Map.Map String GLTipe
     , varying :: Map.Map String GLTipe
     }
-    deriving (Show)
+    deriving (Eq, Show)

src/AST/Type.hs

@@ -56,7 +56,7 @@ data Aliased t
 data Port t
     = Normal t
     | Signal { root :: t, arg :: t }
-    deriving (Show)
+    deriving (Eq, Show)
 
 
 getPortType :: Port tipe -> tipe

src/Generate/JavaScript.hs

@@ -371,28 +371,59 @@ generateDecisionTree root decisionTree =
     DT.Match (Opt.Jump target) ->
         return [ BreakStmt () (Just (targetLabel root target)) ]
 
-    DT.Decision testPath edges fallback ->
-        do  accessExpr <- generateJsExpr (pathToExpr root testPath)
-
-            let testExpr =
-                  case fst (head edges) of
-                    DT.Constructor _ ->
-                        DotRef () accessExpr (Id () "ctor")
-
-                    DT.Literal _ ->
-                        accessExpr
+    DT.Decision testPath [(test, subTree)] (Just fallback) ->
+        let
+          (tests, deepestSubTree) =
+            collapseTests [(testPath, test)] fallback subTree
+
+          makeTest (path, test) =
+            do  testExpr <- pathToTestableExpr root path test
+                return (InfixExpr () OpStrictEq testExpr (testToExpr test))
+        in
+          do  testExprs <- mapM makeTest tests
+              let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs
+              thenBranch <- generateDecisionTree root deepestSubTree
+              elseBranch <- generateDecisionTree root fallback
+              return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]
 
+    DT.Decision testPath edges fallback ->
+        do  testExpr <- pathToTestableExpr root testPath (fst (head edges))
             caseClauses <- mapM (edgeToCaseClause root) edges
             caseDefault <- fallbackToDefault root fallback
-
             return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]
 
 
+collapseTests
+    :: [(DT.Path, DT.Test)]
+    -> DT.DecisionTree Opt.Jump
+    -> DT.DecisionTree Opt.Jump
+    -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)
+collapseTests tests outerFallback decisionTree =
+  case decisionTree of
+    DT.Decision testPath [(test, subTree)] (Just fallback)
+        | fallback == outerFallback ->
+            collapseTests ((testPath, test) : tests) outerFallback subTree
+
+    _ ->
+        (tests, decisionTree)
+
+
 edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())
 edgeToCaseClause root (test, subTree) =
   CaseClause () (testToExpr test) <$> generateDecisionTree root subTree
 
 
+pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())
+pathToTestableExpr root path exampleTest =
+  do  accessExpr <- generateJsExpr (pathToExpr root path)
+      case exampleTest of
+        DT.Constructor _ ->
+            return (DotRef () accessExpr (Id () "ctor"))
+
+        DT.Literal _ ->
+            return accessExpr
+
+
 testToExpr :: DT.Test -> Expression ()
 testToExpr test =
   case test of
@@ -419,15 +450,17 @@ fallbackToDefault root fallback =
 
 generateBranch :: String -> Opt.Branch -> State Int [Statement ()]
 generateBranch root (Opt.Branch substitutions expr) =
-  do  subts <- mapM (loadPath root) substitutions
+  do  substs <- mapM (loadPath root) substitutions
+      let substStmts =
+            if null substs then [] else [ VarDeclStmt () substs ]
       code <- generateCode expr
-      return (subts ++ toStatementList code)
+      return (substStmts ++ toStatementList code)
 
 
-loadPath :: String -> (String, DT.Path) -> State Int (Statement ())
+loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())
 loadPath root (name, path) =
   do  jsAccessExpr <- generateJsExpr (pathToExpr root path)
-      return $ VarDeclStmt () [ varDecl name jsAccessExpr ]
+      return $ varDecl (Var.safe name) jsAccessExpr
 
 
 pathToExpr :: String -> DT.Path -> Opt.Expr

src/Optimize/Patterns/DecisionTree.hs

@@ -12,7 +12,6 @@ as SML/NJ to get nice trees.
 -}
 
 import Control.Arrow (second)
-import Data.Function (on)
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -74,6 +73,7 @@ data DecisionTree a
         , _edges :: [(Test, DecisionTree a)]
         , _default :: Maybe (DecisionTree a)
         }
+    deriving (Eq)
 
 
 data Jump = Jump
@@ -144,37 +144,23 @@ toDecisionTree variantDict rawBranches =
     Nothing ->
         let
           path =
-              smallDefaults branches
-
-          relevantTests =
-              testsAtPath path branches
-
-          allRawEdges =
-              map (edgesFor path branches) relevantTests
-
-          (rawEdges, unexplored) =
-              if isComplete variantDict relevantTests then
-                  ( init allRawEdges
-                  , snd (last allRawEdges)
-                  )
+              pickPath variantDict branches
 
-              else
-                  ( allRawEdges
-                  , filter (isIrrelevantTo path) branches
-                  )
+          (edges, fallback) =
+              gatherEdges variantDict branches path
 
-          edges =
-              map (second (toDecisionTree variantDict)) rawEdges
+          decisionEdges =
+              map (second (toDecisionTree variantDict)) edges
         in
-          case (edges, unexplored) of
+          case (decisionEdges, fallback) of
             ([(_tag, decisionTree)], []) ->
                 decisionTree
 
             (_, []) ->
-                Decision path edges Nothing
+                Decision path decisionEdges Nothing
 
             (_, _) ->
-                Decision path edges (Just (toDecisionTree variantDict unexplored))
+                Decision path decisionEdges (Just (toDecisionTree variantDict fallback))
 
 
 isComplete :: VariantDict -> [Test] -> Bool
@@ -283,6 +269,28 @@ getSubstitution (path, A.A _ pattern) =
         Nothing
 
 
+-- GATHER OUTGOING EDGES
+
+gatherEdges :: VariantDict -> [Branch] -> Path -> ([(Test, [Branch])], [Branch])
+gatherEdges variantDict branches path =
+  let
+    relevantTests =
+        testsAtPath path branches
+
+    allRawEdges =
+        map (edgesFor path branches) relevantTests
+  in
+    if isComplete variantDict relevantTests then
+        ( init allRawEdges
+        , snd (last allRawEdges)
+        )
+
+    else
+        ( allRawEdges
+        , filter (isIrrelevantTo path) branches
+        )
+
+
 -- FIND RELEVANT TESTS
 
 testsAtPath :: Path -> [Branch] -> [Test]
@@ -420,18 +428,20 @@ needsTests (A.A _ pattern) =
         True
 
 
--- PATH PICKING HEURISTICS
+-- PICK A PATH
 
-smallDefaults :: [Branch] -> Path
-smallDefaults branches =
+pickPath :: VariantDict -> [Branch] -> Path
+pickPath variantDict branches =
   let
     allPaths =
       Maybe.mapMaybe isChoicePath (concatMap _patterns branches)
-
-    weightedPaths =
-      map (\path -> (path, length (filter (isIrrelevantTo path) branches))) allPaths
   in
-      fst (List.minimumBy (compare `on` snd) weightedPaths)
+    case bests (addWeights (smallDefaults branches) allPaths) of
+      [path] ->
+          path
+
+      tiedPaths ->
+          head (bests (addWeights (smallBranchingFactor variantDict branches) tiedPaths))
 
 
 isChoicePath :: (Path, CPattern) -> Maybe Path
@@ -442,4 +452,38 @@ isChoicePath (path, pattern) =
       Nothing
 
 
--- smallBranchingFactor :: [Branch] -> Path
+addWeights :: (Path -> Int) -> [Path] -> [(Path, Int)]
+addWeights toWeight paths =
+  map (\path -> (path, toWeight path)) paths
+
+
+bests :: [(Path, Int)] -> [Path]
+bests ((path,weight):weightedPaths) =
+  let
+    gatherMinimum acc@(minWeight, paths) (path, weight) =
+      if weight == minWeight then
+        (minWeight, path : paths)
+
+      else if weight < minWeight then
+        (weight, [path])
+
+      else
+        acc
+  in
+    snd (List.foldl' gatherMinimum (weight, [path]) weightedPaths)
+
+
+-- PATH PICKING HEURISTICS
+
+smallDefaults :: [Branch] -> Path -> Int
+smallDefaults branches path =
+  length (filter (isIrrelevantTo path) branches)
+
+
+smallBranchingFactor :: VariantDict -> [Branch] -> Path -> Int
+smallBranchingFactor variantDict branches path =
+  let
+    (edges, fallback) =
+      gatherEdges variantDict branches path
+  in
+    length edges + (if null fallback then 0 else 1)