Merge pull request #132 from JohnLato/strictness-optimizations

Strictness optimizations

diagrams-lib.cabal

@@ -89,6 +89,7 @@ Library
                        active >= 0.1 && < 0.2,
                        vector-space >= 0.7.7 && < 0.9,
                        vector-space-points >= 0.1.2 && < 0.2,
+                       MemoTrie >= 0.6 && < 0.7,
                        NumInstances >= 1.2 && < 1.4,
                        colour >= 2.3.2 && < 2.4,
                        data-default-class < 0.1,

src/Diagrams/Segment.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns               #-}
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE EmptyDataDecls             #-}
 {-# LANGUAGE FlexibleContexts           #-}
@@ -100,7 +101,7 @@ data Closed
 --   a fixed offset from its start.
 data Offset c v where
   OffsetOpen   :: Offset Open v
-  OffsetClosed :: v -> Offset Closed v
+  OffsetClosed :: !v -> Offset Closed v
 
 deriving instance Show v => Show (Offset c v)
 deriving instance Eq   v => Eq   (Offset c v)
@@ -127,10 +128,10 @@ instance HasLinearMap v => Transformable (Offset c v) where
 --   however, affected by other transformations such as rotations and
 --   scales.
 data Segment c v
-    = Linear (Offset c v)
+    = Linear !(Offset c v)
       -- ^ A linear segment with given offset.
 
-    | Cubic v v (Offset c v)
+    | Cubic !v !v !(Offset c v)
       -- ^ A cubic Bézier segment specified by
       --   three offsets from the starting
       --   point to the first control point,
@@ -229,7 +230,7 @@ segOffset (Cubic _ _ (OffsetClosed v)) = v
 instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Segment Closed v) where
 
   getEnvelope (s@(Linear {})) = mkEnvelope $ \v ->
-    maximum . map (\t -> ((s `atParam` t) <.> v) / magnitudeSq v) $ [0,1]
+    maximum (map (\t -> ((s `atParam` t) <.> v)) [0,1]) / magnitudeSq v
 
   getEnvelope (s@(Cubic c1 c2 (OffsetClosed x2))) = mkEnvelope $ \v ->
     maximum .
@@ -430,15 +431,18 @@ instance AdditiveGroup v => Monoid (TotalOffset v) where
 --   combining the envelopes of two consecutive chains needs to take
 --   the offset of the the offset of the first into account.
 data OffsetEnvelope v = OffsetEnvelope
-  { oeOffset   :: TotalOffset v
+  { oeOffset   :: !(TotalOffset v)
   , oeEnvelope :: Envelope v
   }
 
 instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) where
   (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2)
-    = OffsetEnvelope
-        (o1 <> o2)
-        (e1 <> moveOriginBy (negateV . getTotalOffset $ o1) e2)
+    = let !negOff = negateV . getTotalOffset $ o1
+          e2Off = moveOriginBy negOff e2
+          !() = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off
+      in OffsetEnvelope
+          (o1 <> o2)
+          (e1 <> e2Off)
 
 -- | @SegMeasure@ collects up all the measurements over a chain of
 --   segments.

src/Diagrams/TwoD/Size.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies     #-}
+
+{-# OPTIONS_GHC -funbox-strict-fields #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Diagrams.TwoD.Size
@@ -78,15 +80,15 @@ center2D = maybe origin (p2 . (mid *** mid)) . mm . (extentX &&& extentY)
 ------------------------------------------------------------
 
 -- | A specification of a (requested) rectangular size.
-data SizeSpec2D = Width  Double       -- ^ Specify an explicit
+data SizeSpec2D = Width  !Double       -- ^ Specify an explicit
                                       -- width. The height should be
                                       -- determined automatically (so
                                       -- as to preserve aspect ratio).
-                | Height Double       -- ^ Specify an explicit
+                | Height !Double       -- ^ Specify an explicit
                                       -- height. The width should be
                                       -- determined automatically (so
                                       -- as to preserve aspect ratio).
-                | Dims Double Double  -- ^ An explicit specification
+                | Dims !Double !Double  -- ^ An explicit specification
                                       -- of a width and height.
                 | Absolute            -- ^ Absolute size: use whatever
                                       -- size an object already has;

src/Diagrams/TwoD/Types.hs

@@ -38,6 +38,7 @@ import           Data.AffineSpace.Point
 import           Data.Basis
 import           Data.NumInstances.Tuple ()
 import           Data.VectorSpace
+import           Data.MemoTrie (HasTrie (..))
 
 import           Data.Typeable
 import           Control.Lens           (Iso', iso, _1, _2)
@@ -130,15 +131,24 @@ instance VectorSpace R2 where
   type Scalar R2 = Double
   s *^ R2 x y = R2 (s*x) (s*y)
 
+data R2Basis = XB | YB deriving (Eq, Ord, Enum)
+
+instance HasTrie R2Basis where
+    data R2Basis :->: x = R2Trie x x
+    trie f = R2Trie (f XB) (f YB)
+    untrie (R2Trie x _y) XB = x
+    untrie (R2Trie _x y) YB = y
+    enumerate (R2Trie x y)  = [(XB,x),(YB,y)]
+
 instance HasBasis R2 where
-  type Basis R2 = Either () () -- = Basis (Double, Double)
-  basisValue (Left () )          = R2 1 0
-  basisValue (Right ())          = R2 0 1
+  type Basis R2 = R2Basis
+  basisValue XB          = R2 1 0
+  basisValue YB          = R2 0 1
 
-  decompose (R2 x y)             = [(Left (), x), (Right (), y)]
+  decompose (R2 x y)             = [(XB, x), (YB, y)]
 
-  decompose' (R2 x _) (Left ())  = x
-  decompose' (R2 _ y) (Right ()) = y
+  decompose' (R2 x _) (XB)  = x
+  decompose' (R2 _ y) (YB) = y
 
 instance InnerSpace R2 where
   (R2 x1 y1) <.> (R2 x2 y2) = x1*x2 + y1*y2