diff --git a/docs/c-api.rst b/docs/c-api.rst --- a/docs/c-api.rst +++ b/docs/c-api.rst @@ -607,17 +607,19 @@ * The C function name of the entry point. - * A list of all *inputs*, including their type and whether they are - *unique* (consuming). + * A list of all *inputs*, including their type (as a name) and + *whether they are unique* (consuming). - * A list of all *outputs*, including their type and whether they are - *unique*. + * A list of all *outputs*, including their type (as a name) and + *whether they are unique*. * A mapping from the name of each non-scalar type to: - * The C type of used to represent the type (which is in practice + * The C type used to represent this type (which is in practice always a pointer of some kind). + * What *kind* of type this is - either an *array* or an *opaque*. + * For arrays, the element type and rank. * A mapping from *operations* to the names of the C functions that @@ -628,6 +630,15 @@ * For arrays: ``free``, ``shape``, ``values``, ``new``. * For opaques: ``free``, ``store``, ``restore``. + + * For opaques that are actually records (including tuples): + + * The list of fields, including their type and a projection + function. The field ordering here is the one used expected by + the *new* function. + + * The name of the C *new* function for creating a record from + field values. Manifests are defined by the following JSON Schema: diff --git a/futhark.cabal b/futhark.cabal --- a/futhark.cabal +++ b/futhark.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: futhark -version: 0.21.14 +version: 0.21.15 synopsis: An optimising compiler for a functional, array-oriented language. description: Futhark is a small programming language designed to be compiled to diff --git a/rts/c/cuda.h b/rts/c/cuda.h --- a/rts/c/cuda.h +++ b/rts/c/cuda.h @@ -699,7 +699,7 @@ } size_t size; - if (free_list_find(&ctx->free_list, min_size, &size, mem_out) == 0) { + if (free_list_find(&ctx->free_list, min_size, tag, &size, mem_out) == 0) { if (size >= min_size) { if (ctx->cfg.debugging) { fprintf(log, "No need to allocate: Found a block in the free list.\n"); @@ -742,14 +742,6 @@ const char *tag) { size_t size; CUdeviceptr existing_mem; - - // If there is already a block with this tag, then remove it. - if (free_list_find(&ctx->free_list, -1, &size, &existing_mem) == 0) { - CUresult res = cuMemFree(existing_mem); - if (res != CUDA_SUCCESS) { - return res; - } - } CUresult res = cuMemGetAddressRange(NULL, &size, mem); if (res == CUDA_SUCCESS) { diff --git a/rts/c/free_list.h b/rts/c/free_list.h --- a/rts/c/free_list.h +++ b/rts/c/free_list.h @@ -85,16 +85,56 @@ l->used++; } +// Determine whether this entry in the free list is acceptable for +// satisfying the request. +static bool free_list_acceptable(size_t size, const char* tag, struct free_list_entry *entry) { + // We check not just the hard requirement (is the entry acceptable + // and big enough?) but also put a cap on how much wasted space + // (internal fragmentation) we allow. This is necessarily a + // heuristic, and a crude one. + + if (!entry->valid) { + return false; + } + + if (size > entry->size) { + return false; + } + + // We know the block fits. Now the question is whether it is too + // big. Our policy is as follows: + // + // 1) We don't care about wasted space below 4096 bytes (to avoid + // churn in tiny allocations). + // + // 2) If the tag matches, we allow _any_ amount of wasted space. + // + // 3) Otherwise we allow up to 50% wasted space. + + if (entry->size < 4096) { + return true; + } + + if (entry->tag == tag) { + return true; + } + + if (entry->size < size * 2) { + return true; + } + + return false; +} + // Find and remove a memory block of the indicated tag, or if that // does not exist, another memory block with exactly the desired size. // Returns 0 on success. -static int free_list_find(struct free_list *l, size_t size, +static int free_list_find(struct free_list *l, size_t size, const char *tag, size_t *size_out, fl_mem_t *mem_out) { int size_match = -1; int i; for (i = 0; i < l->capacity; i++) { - if (l->entries[i].valid && - size <= l->entries[i].size && + if (free_list_acceptable(size, tag, &l->entries[i]) && (size_match < 0 || l->entries[i].size < l->entries[size_match].size)) { // If this entry is valid, has sufficient size, and is smaller than the // best entry found so far, use this entry. diff --git a/rts/c/opencl.h b/rts/c/opencl.h --- a/rts/c/opencl.h +++ b/rts/c/opencl.h @@ -966,20 +966,8 @@ size_t size; - if (free_list_find(&ctx->free_list, min_size, &size, mem_out) == 0) { + if (free_list_find(&ctx->free_list, min_size, tag, &size, mem_out) == 0) { // Successfully found a free block. Is it big enough? - // - // FIXME: we might also want to check whether the block is *too - // big*, to avoid internal fragmentation. However, this can - // sharply impact performance on programs where arrays change size - // frequently. Fortunately, such allocations are usually fairly - // short-lived, as they are necessarily within a loop, so the risk - // of internal fragmentation resulting in an OOM situation is - // limited. However, it would be preferable if we could go back - // and *shrink* oversize allocations when we encounter an OOM - // condition. That is technically feasible, since we do not - // expose OpenCL pointer values directly to the application, but - // instead rely on a level of indirection. if (size >= min_size) { if (ctx->cfg.debugging) { fprintf(log, "No need to allocate: Found a block in the free list.\n"); @@ -1034,14 +1022,6 @@ static int opencl_free(struct opencl_context *ctx, cl_mem mem, const char *tag) { size_t size; cl_mem existing_mem; - - // If there is already a block with this tag, then remove it. - if (free_list_find(&ctx->free_list, -1, &size, &existing_mem) == 0) { - int error = clReleaseMemObject(existing_mem); - if (error != CL_SUCCESS) { - return error; - } - } int error = clGetMemObjectInfo(mem, CL_MEM_SIZE, sizeof(size_t), &size, NULL); diff --git a/src/Futhark/CLI/Test.hs b/src/Futhark/CLI/Test.hs --- a/src/Futhark/CLI/Test.hs +++ b/src/Futhark/CLI/Test.hs @@ -594,10 +594,9 @@ -- Removes "Now testing" output. when fancy $ cursorUpLine 1 >> clearLine - let excluded_str - | null excluded = "" - | otherwise = " (" ++ show (length excluded) ++ " program(s) excluded).\n" - putStr excluded_str + unless (null excluded) . putStrLn $ + show (length excluded) ++ " program(s) excluded." + exitWith $ case testStatusFail ts of 0 -> ExitSuccess _ -> ExitFailure 1 diff --git a/src/Futhark/CodeGen/Backends/GenericC.hs b/src/Futhark/CodeGen/Backends/GenericC.hs --- a/src/Futhark/CodeGen/Backends/GenericC.hs +++ b/src/Futhark/CodeGen/Backends/GenericC.hs @@ -283,13 +283,16 @@ // We preserve the original error so that a savvy user can perhaps find // glory despite our naiveté. + // We cannot use set_error() here because we want to replace the old error. + lock_lock(&ctx->error_lock); char *old_error = ctx->error; - set_error(ctx, msgprintf("Failed to allocate memory in %s.\nAttempted allocation: %12lld bytes\nCurrently allocated: %12lld bytes\n%s", - $string:spacedesc, - (long long) size, - (long long) ctx->$id:usagename, - old_error)); + ctx->error = msgprintf("Failed to allocate memory in %s.\nAttempted allocation: %12lld bytes\nCurrently allocated: %12lld bytes\n%s", + $string:spacedesc, + (long long) size, + (long long) ctx->$id:usagename, + old_error); free(old_error); + lock_unlock(&ctx->error_lock); return FUTHARK_OUT_OF_MEMORY; } }|] diff --git a/src/Futhark/Compiler/Program.hs b/src/Futhark/Compiler/Program.hs --- a/src/Futhark/Compiler/Program.hs +++ b/src/Futhark/Compiler/Program.hs @@ -99,10 +99,6 @@ newState :: [ImportName] -> IO ReaderState newState known = newMVar $ M.fromList $ zip known $ repeat Nothing --- Since we need to work with base 4.14 that does not have NE.singleton. -singleError :: ProgError -> NE.NonEmpty ProgError -singleError = (NE.:| []) - orderedImports :: [(ImportName, MVar UncheckedImport)] -> IO [(ImportName, WithErrors (LoadedFile E.UncheckedProg))] @@ -116,7 +112,7 @@ <> intercalate " -> " (map includeToString $ reverse $ include : steps) - modify ((include, Left (singleError problem)) :) + modify ((include, Left (NE.singleton problem)) :) | otherwise = do prev <- gets $ lookup include case prev of @@ -189,7 +185,7 @@ handleFile state_mvar vfs (LoadedFile file_name import_name file_contents mod_time) = do case parseFuthark file_name file_contents of Left (SyntaxError loc err) -> - pure . UncheckedImport . Left . singleError $ ProgError loc $ text err + pure . UncheckedImport . Left . NE.singleton $ ProgError loc $ text err Right prog -> do let imports = map (uncurry (mkImportFrom import_name)) $ E.progImports prog mvars <- @@ -212,7 +208,7 @@ Nothing -> do prog_mvar <- newImportMVar $ do readImportFile include vfs >>= \case - Left e -> pure $ UncheckedImport $ Left $ singleError e + Left e -> pure $ UncheckedImport $ Left $ NE.singleton e Right file -> handleFile state_mvar vfs file pure (M.insert include prog_mvar state, prog_mvar) @@ -247,12 +243,12 @@ lfPath = fp } Just (Left e) -> - pure . UncheckedImport . Left . singleError $ + pure . UncheckedImport . Left . NE.singleton $ ProgError NoLoc $ text $ show e Nothing -> - pure . UncheckedImport . Left . singleError $ + pure . UncheckedImport . Left . NE.singleton $ ProgError NoLoc $ text $ fp <> ": file not found." diff --git a/src/Futhark/Internalise/Bindings.hs b/src/Futhark/Internalise/Bindings.hs --- a/src/Futhark/Internalise/Bindings.hs +++ b/src/Futhark/Internalise/Bindings.hs @@ -146,7 +146,6 @@ flattenPat' $ E.Id name t loc flattenPat' (E.Id v (Info t) loc) = pure [(E.Ident v (Info t) loc, mempty)] - -- XXX: treat empty tuples and records as unit. flattenPat' (E.TuplePat [] loc) = flattenPat' (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc) flattenPat' (E.RecordPat [] loc) = diff --git a/src/Futhark/Internalise/Exps.hs b/src/Futhark/Internalise/Exps.hs --- a/src/Futhark/Internalise/Exps.hs +++ b/src/Futhark/Internalise/Exps.hs @@ -581,9 +581,6 @@ ses <- internaliseAppExp desc appres e bindExtSizes appres ses pure ses - --- XXX: we map empty records and tuples to units, because otherwise --- arrays of unit will lose their sizes. internaliseExp _ (E.TupLit [] _) = pure [constant UnitValue] internaliseExp _ (E.RecordLit [] _) = @@ -880,11 +877,10 @@ compares pat ses compares (E.PatAttr _ pat _) ses = compares pat ses - -- XXX: treat empty tuples and records as bool. compares (E.TuplePat [] loc) ses = - compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses + compares (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc) ses compares (E.RecordPat [] loc) ses = - compares (E.Wildcard (Info $ E.Scalar $ E.Prim E.Bool) loc) ses + compares (E.Wildcard (Info $ E.Scalar $ E.Record mempty) loc) ses compares (E.TuplePat pats _) ses = comparesMany pats ses compares (E.RecordPat fs _) ses = diff --git a/src/Futhark/Pkg/Types.hs b/src/Futhark/Pkg/Types.hs --- a/src/Futhark/Pkg/Types.hs +++ b/src/Futhark/Pkg/Types.hs @@ -76,7 +76,7 @@ -- | @commitVersion timestamp commit@ constructs a commit version. commitVersion :: T.Text -> T.Text -> SemVer commitVersion time commit = - SemVer 0 0 0 [Str time NE.:| []] (Just commit) + SemVer 0 0 0 [NE.singleton (Str time)] (Just commit) -- | Unfortunately, Data.Versions has a buggy semver parser that -- collapses consecutive zeroes in the metadata field. So, we define diff --git a/src/Language/Futhark/Parser/Parser.y b/src/Language/Futhark/Parser/Parser.y --- a/src/Language/Futhark/Parser/Parser.y +++ b/src/Language/Futhark/Parser/Parser.y @@ -778,7 +778,7 @@ in AppExp (Match $2 $> loc) NoInfo } Cases :: { NE.NonEmpty (CaseBase NoInfo Name) } - : Case %prec caseprec { $1 NE.:| [] } + : Case %prec caseprec { NE.singleton $1 } | Case Cases { NE.cons $1 $2 } Case :: { CaseBase NoInfo Name } diff --git a/src/Language/Futhark/TypeChecker/Terms.hs b/src/Language/Futhark/TypeChecker/Terms.hs --- a/src/Language/Futhark/TypeChecker/Terms.hs +++ b/src/Language/Futhark/TypeChecker/Terms.hs @@ -738,7 +738,7 @@ case NE.uncons rest_cs of (c, Nothing) -> do (c', t, retext) <- checkCase mt c - pure (c' NE.:| [], t, retext) + pure (NE.singleton c', t, retext) (c, Just cs) -> do (((c', c_t, _), (cs', cs_t, _)), dflow) <- tapOccurrences $ checkCase mt c `alternative` checkCases mt cs