From 063a9390f75f553394bfc66e163ab39ab7c4e87f Mon Sep 17 00:00:00 2001 From: Kazuki Okamoto Date: Wed, 26 Apr 2023 21:49:49 +0900 Subject: [PATCH 1/3] fix compilation errors --- api/src/OpenTelemetry/Attributes.hs | 2 +- api/src/OpenTelemetry/Trace/Core.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/api/src/OpenTelemetry/Attributes.hs b/api/src/OpenTelemetry/Attributes.hs index dbc1d682..51e97eda 100644 --- 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 index 58373ccd..631ab80c 100644 --- a/api/src/OpenTelemetry/Trace/Core.hs +++ b/api/src/OpenTelemetry/Trace/Core.hs @@ -520,7 +520,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 `seq` i {spanName = n} updateName (FrozenSpan _) _ = pure () updateName (Dropped _) _ = pure () From 195238a64bf361dfaec6919b49c02be247336feb Mon Sep 17 00:00:00 2001 From: Kazuki Okamoto Date: Wed, 26 Apr 2023 22:03:57 +0900 Subject: [PATCH 2/3] use bang patterns instead of seq --- api/src/OpenTelemetry/Trace/Core.hs | 90 ++++++++++++++--------------- 1 file changed, 43 insertions(+), 47 deletions(-) diff --git a/api/src/OpenTelemetry/Trace/Core.hs b/api/src/OpenTelemetry/Trace/Core.hs index 631ab80c..ee551f89 100644 --- 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 `seq` 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 From 21fa33ce1786a3cfe4125b8b49f7e1ce0b349543 Mon Sep 17 00:00:00 2001 From: Kazuki Okamoto Date: Wed, 19 Apr 2023 22:09:04 +0900 Subject: [PATCH 3/3] refresh CI cache --- .github/workflows/haskell.yml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 98aef487..b3e7bb6e 100644 --- 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