Merge pull request #1 from herp-inc/api-fix-memory-leak

Fix compilation errors etc.
MercuryTechnologies · Apr 26, 2023 · 5f8b3d1 · 5f8b3d1
2 parents 6af0688 + 21fa33c
commit 5f8b3d1
Show file tree

Hide file tree

Showing 3 changed files with 47 additions and 54 deletions.
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
@@ -17,9 +17,8 @@ jobs:
           path: |
             ~/.stack
             .stack-work
-          key: stack-${{ runner.os }}-8.12-${{ hashFiles('stack-ghc-8.12.yaml.lock') }}
+          key: stack-${{ runner.os }}-8.12-${{ hashFiles('stack-ghc-8.12.yaml.lock') }}-2
           restore-keys: |
-            stack-${{ runner.os }}-8.12
       - run: stack --stack-yaml stack-ghc-8.12.yaml build --only-dependencies
       - run: stack --stack-yaml stack-ghc-8.12.yaml build
       - run: stack --stack-yaml stack-ghc-8.12.yaml test
@@ -39,9 +38,8 @@ jobs:
           path: |
             ~/.stack
             .stack-work
-          key: stack-${{ runner.os }}-${{ hashFiles('stack.yaml.lock') }}
+          key: stack-${{ runner.os }}-${{ hashFiles('stack.yaml.lock') }}-2
           restore-keys: |
-            stack-${{ runner.os }}
       - run: stack build --only-dependencies
       - run: stack build
       - run: stack test
@@ -61,9 +59,8 @@ jobs:
           path: |
             ~/.stack
             .stack-work
-          key: stack-${{ runner.os }}-9.2-${{ hashFiles('stack-ghc-9.2.yaml.lock') }}
+          key: stack-${{ runner.os }}-9.2-${{ hashFiles('stack-ghc-9.2.yaml.lock') }}-2
           restore-keys: |
-            stack-${{ runner.os }}-9.2
       - run: stack --stack-yaml stack-ghc-9.2.yaml build --only-dependencies
       - run: stack --stack-yaml stack-ghc-9.2.yaml build
       - run: stack --stack-yaml stack-ghc-9.2.yaml test

diff --git a/api/src/OpenTelemetry/Attributes.hs b/api/src/OpenTelemetry/Attributes.hs
@@ -114,7 +114,7 @@ addAttribute AttributeLimits {..} Attributes {..} !k !v = case attributeCountLim
 
 addAttributes :: ToAttribute a => AttributeLimits -> Attributes -> [(Text, a)] -> Attributes
 -- TODO, this could be done more efficiently
-addAttributes limits = foldl' (\!attrs' (!k, !v) -> addAttribute limits attrs' k v)
+addAttributes limits = foldl' (\(!attrs') (!k, !v) -> addAttribute limits attrs' k v)
 {-# INLINE addAttributes #-}
 
 

diff --git a/api/src/OpenTelemetry/Trace/Core.hs b/api/src/OpenTelemetry/Trace/Core.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
@@ -426,16 +427,15 @@ addAttribute ::
   -- | Attribute value
   a ->
   m ()
-addAttribute (Span s) k v = liftIO $ modifyIORef' s $ \i ->
-  i `seq`
-    i
-      { spanAttributes =
-          OpenTelemetry.Attributes.addAttribute
-            (limitBy (spanTracer i) spanAttributeCountLimit)
-            (spanAttributes i)
-            k
-            v
-      }
+addAttribute (Span s) k v = liftIO $ modifyIORef' s $ \(!i) ->
+  i
+    { spanAttributes =
+        OpenTelemetry.Attributes.addAttribute
+          (limitBy (spanTracer i) spanAttributeCountLimit)
+          (spanAttributes i)
+          k
+          v
+    }
 addAttribute (FrozenSpan _) _ _ = pure ()
 addAttribute (Dropped _) _ _ = pure ()
 
@@ -447,15 +447,14 @@ addAttribute (Dropped _) _ _ = pure ()
  @since 0.0.1.0
 -}
 addAttributes :: MonadIO m => Span -> [(Text, A.Attribute)] -> m ()
-addAttributes (Span s) attrs = liftIO $ modifyIORef' s $ \i ->
-  i `seq`
-    i
-      { spanAttributes =
-          OpenTelemetry.Attributes.addAttributes
-            (limitBy (spanTracer i) spanAttributeCountLimit)
-            (spanAttributes i)
-            attrs
-      }
+addAttributes (Span s) attrs = liftIO $ modifyIORef' s $ \(!i) ->
+  i
+    { spanAttributes =
+        OpenTelemetry.Attributes.addAttributes
+          (limitBy (spanTracer i) spanAttributeCountLimit)
+          (spanAttributes i)
+          attrs
+    }
 addAttributes (FrozenSpan _) _ = pure ()
 addAttributes (Dropped _) _ = pure ()
 
@@ -467,21 +466,20 @@ addAttributes (Dropped _) _ = pure ()
 addEvent :: MonadIO m => Span -> NewEvent -> m ()
 addEvent (Span s) NewEvent {..} = liftIO $ do
   t <- maybe getTimestamp pure newEventTimestamp
-  modifyIORef' s $ \i ->
-    i `seq`
-      i
-        { spanEvents =
-            appendToBoundedCollection (spanEvents i) $
-              Event
-                { eventName = newEventName
-                , eventAttributes =
-                    A.addAttributes
-                      (limitBy (spanTracer i) eventAttributeCountLimit)
-                      emptyAttributes
-                      newEventAttributes
-                , eventTimestamp = t
-                }
-        }
+  modifyIORef' s $ \(!i) ->
+    i
+      { spanEvents =
+          appendToBoundedCollection (spanEvents i) $
+            Event
+              { eventName = newEventName
+              , eventAttributes =
+                  A.addAttributes
+                    (limitBy (spanTracer i) eventAttributeCountLimit)
+                    emptyAttributes
+                    newEventAttributes
+              , eventTimestamp = t
+              }
+      }
 addEvent (FrozenSpan _) _ = pure ()
 addEvent (Dropped _) _ = pure ()
 
@@ -493,14 +491,13 @@ addEvent (Dropped _) _ = pure ()
  @since 0.0.1.0
 -}
 setStatus :: MonadIO m => Span -> SpanStatus -> m ()
-setStatus (Span s) st = liftIO $ modifyIORef' s $ \i ->
-  i `seq`
-    i
-      { spanStatus =
-          if st > spanStatus i
-            then st
-            else spanStatus i
-      }
+setStatus (Span s) st = liftIO $ modifyIORef' s $ \(!i) ->
+  i
+    { spanStatus =
+        if st > spanStatus i
+          then st
+          else spanStatus i
+    }
 setStatus (FrozenSpan _) _ = pure ()
 setStatus (Dropped _) _ = pure ()
 
@@ -520,7 +517,7 @@ updateName ::
   -- | The new span name, which supersedes whatever was passed in when the Span was started
   Text ->
   m ()
-updateName (Span s) n = liftIO $ modifyIORef' s $ \i -> i `sew` i {spanName = n}
+updateName (Span s) n = liftIO $ modifyIORef' s $ \(!i) -> i {spanName = n}
 updateName (FrozenSpan _) _ = pure ()
 updateName (Dropped _) _ = pure ()
 
@@ -543,10 +540,9 @@ endSpan ::
   m ()
 endSpan (Span s) mts = liftIO $ do
   ts <- maybe getTimestamp pure mts
-  (alreadyFinished, frozenS) <- atomicModifyIORef' s $ \i ->
-    i `seq`
-      let ref = i {spanEnd = spanEnd i <|> Just ts}
-       in (ref, (isJust $ spanEnd i, ref))
+  (alreadyFinished, frozenS) <- atomicModifyIORef' s $ \(!i) ->
+    let ref = i {spanEnd = spanEnd i <|> Just ts}
+     in (ref, (isJust $ spanEnd i, ref))
   unless alreadyFinished $ do
     eResult <- try $ mapM_ (`processorOnEnd` s) $ tracerProviderProcessors $ tracerProvider $ spanTracer frozenS
     case eResult of