From d4b992fb1bf4d84b9306b7ed009a12c19b28b0d9 Mon Sep 17 00:00:00 2001 From: Huw Campbell Date: Thu, 27 Jun 2024 21:39:18 +1000 Subject: [PATCH] Improve complexity of delete from O(N) to O(log(n)) Also make the C delete function mutable, so the optimiser can omit the delete when the operations are linear. --- data/sea/30-array.h | 20 +-- .../Avalanche/Statement/Flatten/Algorithms.hs | 116 ++++++++---------- .../Icicle/Avalanche/Statement/Simp/Linear.hs | 3 - 3 files changed, 56 insertions(+), 83 deletions(-) diff --git a/data/sea/30-array.h b/data/sea/30-array.h index 6ad056bb..087d6013 100644 --- a/data/sea/30-array.h +++ b/data/sea/30-array.h @@ -247,7 +247,7 @@ static ARRAY_T(t) INLINE ARRAY_FUN(t,swap) /* -Immutable Delete (arr, ix) +Mutable Delete (arr, ix) */ #define MK_ARRAY_DELETE(t) \ @@ -258,25 +258,17 @@ static ARRAY_T(t) INLINE ARRAY_FUN(t,delete) VALID_ARRAY(x) \ VALID_INDEX(ix_delete, x) \ \ - iint_t count = x->count; \ - iint_t capacity = iarray_size(count - 1); \ - size_t bytes = ARRAY_SIZE(t, capacity); \ + iint_t count = x->count; \ \ - ARRAY_T(t) arr = (ARRAY_T(t))anemone_mempool_alloc(pool, bytes); \ - \ - for (iint_t ix = 0; ix != ix_delete; ++ix) { \ - t##_t val = ARRAY_PAYLOAD(t,x)[ix]; \ - ARRAY_PAYLOAD(t,arr)[ix] = val; \ - } \ for (iint_t ix = ix_delete + 1; ix != count; ++ix) { \ t##_t val = ARRAY_PAYLOAD(t,x)[ix]; \ - ARRAY_PAYLOAD(t,arr)[ix - 1] = val; \ + ARRAY_PAYLOAD(t,x)[ix - 1] = val; \ } \ \ - arr->count = count - 1; \ + x->count = count - 1; \ \ - VALID_ARRAY(arr) \ - return arr; \ + VALID_ARRAY(x) \ + return x; \ } diff --git a/icicle-compiler/src/Icicle/Avalanche/Statement/Flatten/Algorithms.hs b/icicle-compiler/src/Icicle/Avalanche/Statement/Flatten/Algorithms.hs index dca67590..7d030efe 100644 --- a/icicle-compiler/src/Icicle/Avalanche/Statement/Flatten/Algorithms.hs +++ b/icicle-compiler/src/Icicle/Avalanche/Statement/Flatten/Algorithms.hs @@ -98,30 +98,6 @@ updateAcc a_fresh acc t x = do n'x <- freshPrefix "update_acc" return $ Read n'x acc t $ Write acc $ x $ XVar a_fresh n'x -pushArrayAcc :: (Hashable n, Monad m, IsString n) - => a -> ValType -> Name n -> Flat.X a n - -> FreshT n m (Flat.S a n) -pushArrayAcc a_fresh t n'acc push - = do let t' = ArrayT t - sz arr = arrLen t arr - put arr i x = arrUpd t arr i x - - updateAcc a_fresh n'acc t' (\arr -> put arr (sz arr) push) - where - Flat.FlatOps {..} = Flat.flatOps a_fresh - --- | Immutable put -putArrayAcc :: (Hashable n, Monad m, IsString n) - => a -> ValType -> Name n -> Flat.X a n -> Flat.X a n - -> FreshT n m (Flat.S a n) -putArrayAcc a_fresh t n'acc idx push - = do let t' = ArrayT t - put arr i x = arrUpd t arr i x - - updateAcc a_fresh n'acc t' (\arr -> put arr idx push) - where - Flat.FlatOps {..} = Flat.flatOps a_fresh - -- | Mutable put putArrayAcc' :: (Hashable n, Monad m, IsString n) => a -> ValType -> Name n -> Flat.X a n -> Flat.X a n @@ -686,63 +662,71 @@ avalancheMapDelete -> FlatM a n avalancheMapDelete a_fresh stm flatX tk tv key map = flatX' key $ \key' -> flatX' map $ \map' -> do - n'map'k <- fresh - n'map'v <- fresh - n'map'sz <- fresh - let acc'map'k= Accumulator n'map'k (ArrayT tk) (mapKeys tk tv map') - acc'map'v= Accumulator n'map'v (ArrayT tv) (mapVals tk tv map') + n_acc_keys <- freshPrefix "map_insert_acc_keys" + n_acc_vals <- freshPrefix "map_insert_acc_vals" + n_acc_idx <- freshPrefix "map_insert_acc_bs_index" + n_acc_found <- freshPrefix "map_insert_acc_bs_found" + n_loc_keys <- freshPrefix "map_insert_loc_keys" + n_loc_vals <- freshPrefix "map_insert_loc_vals" + n_cpy_keys <- freshPrefix "map_insert_cpy_keys" + n_cpy_vals <- freshPrefix "map_insert_cpy_vals" + n_loc_idx <- freshPrefix "map_insert_loc_bs_index" + n_loc_found <- freshPrefix "map_insert_loc_bs_found" + n_res <- freshPrefix "map_insert_result" - x'map'k = xVar n'map'k - x'map'v = xVar n'map'v + let v_keys = xVar n_loc_keys + v_vals = xVar n_loc_vals + v_idx = xVar n_loc_idx + v_found = xVar n_loc_found + v_res = xVar n_res - read'k = Read n'map'k n'map'k (ArrayT tk) - read'v = Read n'map'v n'map'v (ArrayT tv) + let acc_idx = Accumulator n_acc_idx IntT $ xValue IntT (VInt (-1)) + acc_found = Accumulator n_acc_found BoolT $ xFalse + acc_keys = Accumulator n_acc_keys (ArrayT tk) $ mapKeys tk tv map' + acc_vals = Accumulator n_acc_vals (ArrayT tv) $ mapVals tk tv map' - sz = xVar n'map'sz - get'k i = arrIx tk x'map'k i + let readk = readArr tk n_loc_keys n_acc_keys + readv = readArr tv n_loc_vals n_acc_vals + readk' = readArr tk n_cpy_keys n_acc_keys + readv' = readArr tv n_cpy_vals n_acc_vals + readix = readBool n_loc_found n_acc_found + . readInt n_loc_idx n_acc_idx - del'k i = arrDel tk x'map'k i - del'v i = arrDel tv x'map'v i + -- Look up the key. + sLookup <- avalancheBinarySearch a_fresh tk key' v_keys n_acc_found n_acc_idx - del' i = Block - [ Write n'map'k (del'k i) - , Write n'map'v (del'v i) - ] + -- If it's found, we'll need a copy. + copyk <- copyArrayAcc a_fresh tk n_acc_keys + copyv <- copyArrayAcc a_fresh tv n_acc_vals - loop1 <- forReverse sz - $ \i - -> (read'k - <$> (read'v - <$> pure (If (relEq tk (get'k i) key') (del' i) mempty))) + -- Perform the delete (this will also update the count) + let del = Write n_acc_keys (arrDel tk (xVar n_cpy_keys) v_idx) + <> Write n_acc_vals (arrDel tv (xVar n_cpy_vals) v_idx) - n'map' <- fresh - stm' <- stm $ xVar n'map' + let sDel = copyk <> copyv <> readk' (readv' del) - let stm'' = read'k - $ read'v - $ Let n'map' (mapPack tk tv x'map'k x'map'v) - $ stm' + let keyInMap = relEq BoolT v_found xTrue + let sInsertOrUpdate = If keyInMap sDel mempty - ss = InitAccumulator acc'map'k - $ InitAccumulator acc'map'v - $ read'k - $ Let n'map'sz (arrLen tk x'map'k) - ( loop1 <> stm'' ) + stm' <- stm v_res + let res = Let n_res (mapPack tk tv v_keys v_vals) stm' + ss = InitAccumulator acc_keys + $ InitAccumulator acc_vals + $ InitAccumulator acc_found + $ InitAccumulator acc_idx + $ readk . readv . readix + $ sLookup <> (readix (sInsertOrUpdate <> readk (readv res))) return ss where - flatX' - = flatX a_fresh - - forReverse len - = forI_ a_fresh ForeachStepDown (xMinusOne len) (XValue a_fresh IntT (VInt (-1))) - - xMinusOne m - = xArith Min.PrimArithMinus `xApp` m `xApp` xValue IntT (VInt 1) + xTrue = xValue BoolT (VBool True) + xFalse = xValue BoolT (VBool False) - Flat.FlatCons {..} = Flat.flatCons a_fresh + flatX' = flatX a_fresh Flat.FlatOps {..} = Flat.flatOps a_fresh + Flat.FlatCons {..} = Flat.flatCons a_fresh + -------------------------------------------------------------------------------- diff --git a/icicle-compiler/src/Icicle/Avalanche/Statement/Simp/Linear.hs b/icicle-compiler/src/Icicle/Avalanche/Statement/Simp/Linear.hs index 46fa749b..dfc7a803 100644 --- a/icicle-compiler/src/Icicle/Avalanche/Statement/Simp/Linear.hs +++ b/icicle-compiler/src/Icicle/Avalanche/Statement/Simp/Linear.hs @@ -191,9 +191,6 @@ linearise = _ | Just (Flat.PrimUnsafe (Flat.PrimUnsafeArrayIndex _), [g,_]) <- takePrimApps x -> arrayReference g - _ | Just (Flat.PrimBuf (Flat.PrimBufRead {}), [g]) <- takePrimApps x -> - arrayReference g - _ -> Nothing