From 6f7aeaff73eb7cfcfff075235b5568aa1bc8d1f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Sun, 20 Dec 2020 21:21:14 +0100 Subject: [PATCH] feat: 'delete' interface (deciding whether a type is managed or not) (#1061) * feat: 'delete' interface (deciding whether a type is managed or not) * refactor: Move implements function to Interface module * feat: Automatically implement 'delete' for types defined with `deftype` * fix: Don't implement `delete` for Pointer * refactor: Clarify `memberInfo` function * fix: Also check if function types are managed * fix: Implement 'delete' for String and StaticArray. * fix: Manage String and Pattern. Tests run! * feat: Add `managed?` primitive * docs: Note about primitiveIsManaged * test: Basic test cases for managed / nonmanaged external types * test: Make sure `managed?` primitive works * test: Inactivate sanitizer since we're creating leaks intentionally * feat: Removed 'isExternalType' function * refactor: Decide if struct member takes ref or not when printing ..based on blitable interface, and 'prn' implemntation * refactor: Use 'blit' everywhere * refactor: Implement `strTakesRefOrNot` in terms of `memberStrCallingConvention` * refactor: Use `remove` over `filter not` --- core/Blitable.carp | 59 ++++++++++++++++++++++++++++++++ core/Core.carp | 1 + core/Interfaces.carp | 2 ++ core/Pattern.carp | 1 + core/String.carp | 1 + src/ArrayTemplates.hs | 15 ++++---- src/Concretize.hs | 47 ++++++++++++------------- src/Deftype.hs | 14 ++++---- src/Interfaces.hs | 13 +++++++ src/Managed.hs | 43 ++++++++--------------- src/Primitives.hs | 27 +++++++++++++-- src/StartingEnv.hs | 6 ++++ src/StructUtils.hs | 51 ++++++++++++++-------------- src/Sumtypes.hs | 16 ++++----- src/Validate.hs | 79 +++++++++++++++++++++---------------------- test/init_global.carp | 1 + test/managed.carp | 66 ++++++++++++++++++++++++++++++++++++ test/statistics.carp | 4 +-- 18 files changed, 300 insertions(+), 146 deletions(-) create mode 100644 core/Blitable.carp create mode 100644 test/managed.carp diff --git a/core/Blitable.carp b/core/Blitable.carp new file mode 100644 index 00000000..1bf1087b --- /dev/null +++ b/core/Blitable.carp @@ -0,0 +1,59 @@ +(defmodule Int + (defn blit [x] (the Int x)) + (implements blit Int.blit)) + +(defmodule Long + (defn blit [x] (the Long x)) + (implements blit Long.blit)) + +(defmodule Float + (defn blit [x] (the Float x)) + (implements blit Float.blit)) + +(defmodule Double + (defn blit [x] (the Double x)) + (implements blit Double.blit)) + +(defmodule Char + (defn blit [x] (the Char x)) + (implements blit Char.blit)) + +(defmodule Bool + (defn blit [x] (the Bool x)) + (implements blit Bool.blit)) + +(defmodule Byte + (defn blit [x] (the Byte x)) + (implements blit Byte.blit)) + +(defmodule Int8 + (defn blit [x] (the Int8 x)) + (implements blit Int8.blit)) + +(defmodule Int16 + (defn blit [x] (the Int16 x)) + (implements blit Int16.blit)) + +(defmodule Int32 + (defn blit [x] (the Int32 x)) + (implements blit Int32.blit)) + +(defmodule Int64 + (defn blit [x] (the Int64 x)) + (implements blit Int64.blit)) + +(defmodule Uint8 + (defn blit [x] (the Uint8 x)) + (implements blit Uint8.blit)) + +(defmodule Uint16 + (defn blit [x] (the Uint16 x)) + (implements blit Uint16.blit)) + +(defmodule Uint32 + (defn blit [x] (the Uint32 x)) + (implements blit Uint32.blit)) + +(defmodule Uint64 + (defn blit [x] (the Uint64 x)) + (implements blit Uint64.blit)) diff --git a/core/Core.carp b/core/Core.carp index 03e3fba5..b5ab885f 100644 --- a/core/Core.carp +++ b/core/Core.carp @@ -16,6 +16,7 @@ (system-include "carp_memory.h") (load-once "Interfaces.carp") +(load-once "Blitable.carp") (load-once "Bool.carp") (load-once "Macros.carp") (load-once "List.carp") diff --git a/core/Interfaces.carp b/core/Interfaces.carp index 9b82eaa2..bab10793 100644 --- a/core/Interfaces.carp +++ b/core/Interfaces.carp @@ -65,3 +65,5 @@ (definterface tanh (λ [a] a)) (definterface slice (Fn [&a Int Int] a)) + +(definterface blit (Fn [a] a)) ; For types that can be freely memcopied -- exact name is up for discussion diff --git a/core/Pattern.carp b/core/Pattern.carp index bd04b32a..c18e8b96 100644 --- a/core/Pattern.carp +++ b/core/Pattern.carp @@ -43,6 +43,7 @@ If you want to replace all occurrences of the pattern, use `-1`.") (register = (Fn [&Pattern &Pattern] Bool)) (implements = Pattern.=) (register delete (Fn [Pattern] ())) + (implements delete Pattern.delete) (register copy (Fn [&Pattern] Pattern)) (implements copy Pattern.copy) diff --git a/core/String.carp b/core/String.carp index eec367c3..55614a39 100644 --- a/core/String.carp +++ b/core/String.carp @@ -33,6 +33,7 @@ (implements copy String.copy) (implements prn String.prn) (implements str String.str) + (implements delete String.delete) (doc head "Returns the character at start of string.") (defn head [s] diff --git a/src/ArrayTemplates.hs b/src/ArrayTemplates.hs index d2a10acd..4c7b6348 100644 --- a/src/ArrayTemplates.hs +++ b/src/ArrayTemplates.hs @@ -3,8 +3,8 @@ module ArrayTemplates where import Concretize -import Managed import Obj +import StructUtils import Template import ToTemplate import Types @@ -611,15 +611,16 @@ strTy typeEnv env (StructTy _ [innerType]) = ] strTy _ _ _ = [] -takeAddressOrNot :: TypeEnv -> Ty -> String -takeAddressOrNot typeEnv t = if isManaged typeEnv t then "&" else "" +strTakesRefOrNot :: TypeEnv -> Env -> Ty -> String +strTakesRefOrNot typeEnv env t = + fst $ memberStrCallingConvention "str" typeEnv env t calculateStrSize :: TypeEnv -> Env -> Ty -> String calculateStrSize typeEnv env t = case t of -- If the member type is Unit, don't access the element. UnitTy -> makeTemplate (\functionName -> (functionName ++ "();")) - _ -> makeTemplate (\functionName -> (functionName ++ "(" ++ (takeAddressOrNot typeEnv t) ++ "((" ++ tyToC t ++ "*)a->data)[i]);")) + _ -> makeTemplate (\functionName -> (functionName ++ "(" ++ (strTakesRefOrNot typeEnv env t) ++ "((" ++ tyToC t ++ "*)a->data)[i]);")) where makeTemplate :: (String -> String) -> String makeTemplate strcall = @@ -632,7 +633,7 @@ calculateStrSize typeEnv env t = -- Get the size of the member type's string representation arrayMemberSizeCalc :: (String -> String) -> String arrayMemberSizeCalc strcall = - case findFunctionForMemberIncludePrimitives typeEnv env "prn" (typesStrFunctionType typeEnv t) ("Inside array.", t) of + case findFunctionForMemberIncludePrimitives typeEnv env "prn" (typesStrFunctionType typeEnv env t) ("Inside array.", t) of FunctionFound functionFullName -> unlines [ " temp = " ++ strcall functionFullName, @@ -649,11 +650,11 @@ insideArrayStr :: TypeEnv -> Env -> Ty -> String insideArrayStr typeEnv env t = case t of UnitTy -> makeTemplate (\functionName -> functionName ++ "();") - _ -> makeTemplate (\functionName -> functionName ++ "(" ++ (takeAddressOrNot typeEnv t) ++ "((" ++ tyToC t ++ "*)a->data)[i]);") + _ -> makeTemplate (\functionName -> functionName ++ "(" ++ (strTakesRefOrNot typeEnv env t) ++ "((" ++ tyToC t ++ "*)a->data)[i]);") where makeTemplate :: (String -> String) -> String makeTemplate strcall = - case findFunctionForMemberIncludePrimitives typeEnv env "prn" (typesStrFunctionType typeEnv t) ("Inside array.", t) of + case findFunctionForMemberIncludePrimitives typeEnv env "prn" (typesStrFunctionType typeEnv env t) ("Inside array.", t) of FunctionFound functionFullName -> unlines [ " temp = " ++ strcall functionFullName, diff --git a/src/Concretize.hs b/src/Concretize.hs index 172181cc..4241b51b 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -700,28 +700,28 @@ depsOfPolymorphicFunction typeEnv env visitedDefinitions functionName functionTy -- | Helper for finding the 'delete' function for a type. depsForDeleteFunc :: TypeEnv -> Env -> Ty -> [XObj] depsForDeleteFunc typeEnv env t = - if isManaged typeEnv t + if isManaged typeEnv env t then depsOfPolymorphicFunction typeEnv env [] "delete" (FuncTy [t] UnitTy StaticLifetimeTy) else [] -- | Helper for finding the 'copy' function for a type. depsForCopyFunc :: TypeEnv -> Env -> Ty -> [XObj] depsForCopyFunc typeEnv env t = - if isManaged typeEnv t + if isManaged typeEnv env t then depsOfPolymorphicFunction typeEnv env [] "copy" (FuncTy [RefTy t (VarTy "q")] t StaticLifetimeTy) else [] -- | Helper for finding the 'str' function for a type. depsForPrnFunc :: TypeEnv -> Env -> Ty -> [XObj] depsForPrnFunc typeEnv env t = - if isManaged typeEnv t + if isManaged typeEnv env t then depsOfPolymorphicFunction typeEnv env [] "prn" (FuncTy [RefTy t (VarTy "q")] StringTy StaticLifetimeTy) else depsOfPolymorphicFunction typeEnv env [] "prn" (FuncTy [t] StringTy StaticLifetimeTy) -- | The type of a type's str function. -typesStrFunctionType :: TypeEnv -> Ty -> Ty -typesStrFunctionType typeEnv memberType = - if isManaged typeEnv memberType +typesStrFunctionType :: TypeEnv -> Env -> Ty -> Ty +typesStrFunctionType typeEnv env memberType = + if isManaged typeEnv env memberType then FuncTy [RefTy memberType (VarTy "q")] StringTy StaticLifetimeTy else FuncTy [memberType] StringTy StaticLifetimeTy @@ -743,7 +743,7 @@ getConcretizedPath single functionType = -- | Used for finding functions like 'delete' or 'copy' for members of a Deftype (or Array). findFunctionForMember :: TypeEnv -> Env -> String -> Ty -> (String, Ty) -> FunctionFinderResult findFunctionForMember typeEnv env functionName functionType (memberName, memberType) - | isManaged typeEnv memberType = + | isManaged typeEnv env memberType = case allFunctionsWithNameAndSignature env functionName functionType of [] -> FunctionNotFound @@ -1379,7 +1379,7 @@ manageMemory typeEnv globalEnv root = visit xobj unmanageArg :: XObj -> State MemState (Either TypeError XObj) unmanageArg xobj@(XObj _ _ (Just t)) = - if isManaged typeEnv t + if isManaged typeEnv globalEnv t then do r <- unmanage xobj pure $ case r of @@ -1394,17 +1394,14 @@ manageMemory typeEnv globalEnv root = Just (RefTy _ _) -> Just (RefDeleter (varOfXObj xobj)) Just t -> let var = varOfXObj xobj - in if isExternalType typeEnv t - then Just (FakeDeleter var) - else - if isManaged typeEnv t - then case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of - Just pathOfDeleteFunc -> - Just (ProperDeleter pathOfDeleteFunc var) - Nothing -> - --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj))) - Just (FakeDeleter var) - else Just (PrimDeleter var) + in if isManaged typeEnv globalEnv t + then case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of + Just pathOfDeleteFunc -> + Just (ProperDeleter pathOfDeleteFunc var) + Nothing -> + --trace ("Found no delete function for " ++ var ++ " : " ++ (showMaybeTy (ty xobj))) + Just (FakeDeleter var) + else Just (PrimDeleter var) Nothing -> error ("No type, can't manage " ++ show xobj) manage :: XObj -> State MemState () manage xobj = @@ -1438,7 +1435,7 @@ manageMemory typeEnv globalEnv root = unmanage :: XObj -> State MemState (Either TypeError ()) unmanage xobj = let Just t = xobjTy xobj - in if isManaged typeEnv t && not (isGlobalFunc xobj) && not (isExternalType typeEnv t) + in if isManaged typeEnv globalEnv t && not (isGlobalFunc xobj) then do MemState deleters deps lifetimes <- get case deletersMatchingXObj xobj deleters of @@ -1460,7 +1457,7 @@ manageMemory typeEnv globalEnv root = isGlobalVariable = case xobj of XObj (Sym _ (LookupGlobal _ _)) _ _ -> True _ -> False - in if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv t && not (isExternalType typeEnv t) && not (isSymbolThatCaptures xobj) -- TODO: The 'isManaged typeEnv t' boolean check should be removed! + in if not isGlobalVariable && not (isGlobalFunc xobj) && isManaged typeEnv globalEnv t && not (isSymbolThatCaptures xobj) -- TODO: The 'isManaged typeEnv t' boolean check should be removed! then do MemState deleters _ _ <- get pure $ case deletersMatchingXObj xobj deleters of @@ -1517,7 +1514,7 @@ concreteDelete typeEnv env members = ( \_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv) (map snd members)) + (filter (isManaged typeEnv env) (map snd members)) ) -- | The template for the 'delete' function of a concrete deftype BUT it takes a pointer. @@ -1538,7 +1535,7 @@ concreteDeleteTakePtr typeEnv env members = ( \_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv) (map snd members)) + (filter (isManaged typeEnv env) (map snd members)) ) -- | Generate the C code for deleting a single member of the deftype. @@ -1566,7 +1563,7 @@ concreteCopy typeEnv env memberPairs = ( \_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv) (map snd memberPairs)) + (filter (isManaged typeEnv env) (map snd memberPairs)) ) tokensForCopy :: TypeEnv -> Env -> [(String, Ty)] -> [Token] @@ -1599,7 +1596,7 @@ concreteCopyPtr typeEnv env memberPairs = ( \_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv) (map snd memberPairs)) + (filter (isManaged typeEnv env) (map snd memberPairs)) ) tokensForCopyPtr :: TypeEnv -> Env -> [(String, Ty)] -> [Token] diff --git a/src/Deftype.hs b/src/Deftype.hs index 82381d0c..960c8caa 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -168,7 +168,7 @@ templateSetter typeEnv env memberName memberTy = ) ( \_ -> if - | isManaged typeEnv memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) + | isManaged typeEnv env memberTy -> depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) | isFunctionType memberTy -> [defineFunctionTypeAlias memberTy] | otherwise -> [] ) @@ -206,7 +206,7 @@ templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typ ) ) ( \(FuncTy [_, memberTy] _ _) -> - if isManaged typeEnv memberTy + if isManaged typeEnv env memberTy then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) else [] ) @@ -271,7 +271,7 @@ templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNa ) ) ( \(FuncTy [_, memberTy] _ _) -> - if isManaged typeEnv memberTy + if isManaged typeEnv env memberTy then depsOfPolymorphicFunction typeEnv env [] "delete" (typesDeleterFunctionType memberTy) else [] ) @@ -447,7 +447,7 @@ concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy typeName) _) ) ( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) -> concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) + (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) (remove isFullyGenericType (map snd memberPairs)) ) concreteStr _ _ _ _ _ = error "concretestr" @@ -478,7 +478,7 @@ genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) m correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs memberPairs = memberXObjsToPairs correctedMembers in concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) + (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) (remove isFullyGenericType (map snd memberPairs)) ++ (if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft]) ) @@ -571,7 +571,7 @@ genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _ else concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv) (map snd memberPairs)) + (filter (isManaged typeEnv env) (map snd memberPairs)) ) genericDelete _ _ _ = error "genericdelete" @@ -618,6 +618,6 @@ genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) else concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv) (map snd memberPairs)) + (filter (isManaged typeEnv env) (map snd memberPairs)) ) genericCopy _ _ _ = error "genericcopy" diff --git a/src/Interfaces.hs b/src/Interfaces.hs index 94002d06..c7ef99f1 100644 --- a/src/Interfaces.hs +++ b/src/Interfaces.hs @@ -6,6 +6,7 @@ module Interfaces ( registerInInterfaceIfNeeded, registerInInterface, retroactivelyRegisterInInterface, + interfaceImplementedForTy, ) where @@ -15,6 +16,7 @@ import Control.Monad (foldM) import Env import Lookup import Obj +import Data.Maybe (mapMaybe) import Types import Util @@ -98,3 +100,14 @@ retroactivelyRegisterInInterface ctx interface = env = contextGlobalEnv ctx impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env resultCtx = foldM (\context binder -> registerInInterface context binder interface) ctx impls + +-- | Checks whether an interface is implemented for a certain type signature, +-- | e.g. Is "delete" implemented for `(Fn [String] ())` ? +interfaceImplementedForTy :: TypeEnv -> Env -> String -> Ty -> Bool +interfaceImplementedForTy (TypeEnv typeEnv) globalEnv interfaceName matchingTy = + case lookupBinder (SymPath [] interfaceName) typeEnv of + Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) -> + let lookupType path = forceTy . binderXObj <$> lookupBinder path globalEnv + matches = filter (areUnifiable matchingTy) (mapMaybe lookupType paths) + in not . null $ matches + _ -> False diff --git a/src/Managed.hs b/src/Managed.hs index 77002351..0ef1ae52 100644 --- a/src/Managed.hs +++ b/src/Managed.hs @@ -1,34 +1,21 @@ module Managed where -import Lookup +import Interfaces import Obj import Types --- | Find out if a type is "external", meaning it is not defined by the user --- in this program but instead imported from another C library or similar. --- NOTE: Quite possibly this function should be removed and we should rely on 'isManaged' instead? -isExternalType :: TypeEnv -> Ty -> Bool -isExternalType typeEnv (PointerTy p) = - isExternalType typeEnv p -isExternalType typeEnv (StructTy (ConcreteNameTy name) _) = - case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of - Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> True - _ -> False -isExternalType _ _ = +-- | Should this type be handled by the memory management system. +-- Implementation note: This top-level pattern match should be able to just +-- match on all types and see whether they implement 'delete', but for some +-- reson that doesn't work. Might need to handle generic types separately? +isManaged :: TypeEnv -> Env -> Ty -> Bool +isManaged typeEnv globalEnv structTy@StructTy {} = + interfaceImplementedForTy typeEnv globalEnv "delete" (FuncTy [structTy] UnitTy StaticLifetimeTy) +isManaged typeEnv globalEnv funcTy@FuncTy {} = + interfaceImplementedForTy typeEnv globalEnv "delete" (FuncTy [funcTy] UnitTy StaticLifetimeTy) +isManaged _ _ StringTy = + True +isManaged _ _ PatternTy = + True +isManaged _ _ _ = False - --- | Is this type managed - does it need to be freed? -isManaged :: TypeEnv -> Ty -> Bool -isManaged typeEnv (StructTy (ConcreteNameTy name) _) = - (name == "Array") || (name == "StaticArray") || (name == "Dictionary") - || ( case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of - Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> False - Just (Binder _ (XObj (Lst (XObj (Deftype _) _ _ : _)) _ _)) -> True - Just (Binder _ (XObj (Lst (XObj (DefSumtype _) _ _ : _)) _ _)) -> True - Just (Binder _ (XObj wrong _ _)) -> error ("Invalid XObj in type env: " ++ show wrong) - Nothing -> error ("Can't find " ++ name ++ " in type env.") -- TODO: Please don't crash here! - ) -isManaged _ StringTy = True -isManaged _ PatternTy = True -isManaged _ FuncTy {} = True -isManaged _ _ = False diff --git a/src/Primitives.hs b/src/Primitives.hs index ed92cd79..1eb15e06 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -16,6 +16,7 @@ import Infer import Info import Interfaces import Lookup +import Managed import qualified Meta as Meta import Obj import PrimitiveError @@ -650,17 +651,22 @@ primitiveDeftype xobj ctx (name : rest) = in do ctxWithDeps <- liftIO (foldM (define True) ctx' deps) let fakeImplBinder sympath t = (Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t))) + deleteSig = FuncTy [structTy] UnitTy StaticLifetimeTy strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy + Just deleteInterface = lookupBinder (SymPath [] "delete") (getTypeEnv typeEnv) Just strInterface = lookupBinder (SymPath [] "str") (getTypeEnv typeEnv) Just copyInterface = lookupBinder (SymPath [] "copy") (getTypeEnv typeEnv) + modulePath = SymPath (pathStrings ++ [typeModuleName]) ctxWithInterfaceRegistrations = - -- Since these functions are autogenerated, we treat them as a special case and automatically implement the interfaces. + -- Since these functions are autogenerated, we treat them as a special case + -- and automatically implement the interfaces. foldM (\context (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig) ctxWithDeps - [ ((fakeImplBinder (SymPath (pathStrings ++ [typeModuleName]) "str") strSig), strSig, strInterface), - ((fakeImplBinder (SymPath (pathStrings ++ [typeModuleName]) "copy") copySig), copySig, copyInterface) + [ (fakeImplBinder (modulePath "delete") deleteSig, deleteSig, deleteInterface), + (fakeImplBinder (modulePath "str") strSig, strSig, strInterface), + (fakeImplBinder (modulePath "copy") copySig, copySig, copyInterface) ] case ctxWithInterfaceRegistrations of Left err -> do @@ -895,3 +901,18 @@ openBrowserHelper ctx url = liftIO $ do _ <- openBrowser url return (ctx, dynamicNil) + +-- | Checks if a type is managed. Note that it probably could be implemented in terms +-- of `(implements? )` but to be 100% sure that we use the same lookup as the +-- type system, I've done it this way -- at least for now. +primitiveIsManaged :: Primitive +primitiveIsManaged _ ctx [xobj@(XObj (Sym _ _) i _)] = + let tenv = contextTypeEnv ctx + genv = contextEnv ctx + in case xobjToTy xobj of + Just ty -> + if isManaged tenv genv ty + then pure (ctx, Right trueXObj) + else pure (ctx, Right falseXObj) + Nothing -> pure (evalError ctx ("Can't take type of " ++ pretty xobj) i) +primitiveIsManaged _ _ _ = error "primitiveIsManaged" diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index fdad1ae3..a2e5728a 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -293,6 +293,7 @@ dynamicModule = makeVarPrim "line" "returns the line a symbol was defined on." "(line mysymbol)" primitiveLine, makeVarPrim "column" "returns the column a symbol was defined on." "(column mysymbol)" primitiveColumn, makePrim "info" 1 "prints all information associated with a symbol." "(info mysymbol)" primitiveInfo, + makePrim "managed?" 1 "" "" primitiveIsManaged, makeVarPrim "register-type" "registers a new type from C." "(register-type Name )" primitiveRegisterType, makePrim "defmacro" 3 "defines a new macro." "(defmacro name [args :rest restargs] body)" primitiveDefmacro, makePrim "defndynamic" 3 "defines a new dynamic function, i.e. a function available at compile time." "(defndynamic name [args] body)" primitiveDefndynamic, @@ -458,6 +459,11 @@ startingTypeEnv = bindings = Map.fromList [ interfaceBinder + "delete" + (FuncTy [VarTy "a"] UnitTy StaticLifetimeTy) + ([SymPath ["Array"] "delete", SymPath ["StaticArray"] "delete"] ++ registerFunctionFunctionsWithInterface "delete") + builtInSymbolInfo, + interfaceBinder "copy" (FuncTy [RefTy (VarTy "a") (VarTy "q")] (VarTy "a") StaticLifetimeTy) ([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy"] ++ registerFunctionFunctionsWithInterface "copy") diff --git a/src/StructUtils.hs b/src/StructUtils.hs index a33ebe27..ddb96ccc 100644 --- a/src/StructUtils.hs +++ b/src/StructUtils.hs @@ -1,19 +1,33 @@ module StructUtils where -import Managed +import Interfaces import Obj import Polymorphism import Types -memberInfo :: TypeEnv -> Ty -> (Ty, String, Ty) -memberInfo typeEnv memberTy = - let refOrNotRefType = if isManaged typeEnv memberTy then RefTy memberTy (VarTy "w") else memberTy -- OBS! The VarTy "w" here is dubious - in (refOrNotRefType, if isManaged typeEnv memberTy then "&" else "", FuncTy [refOrNotRefType] StringTy StaticLifetimeTy) +-- | The 'str'/'prn' functions for primitive types don't take refs, while other types do +-- so we need to adjust for that when finding and calling them in compound types. +-- The returned tuple contains ("" || "&", `str function type`). +memberStrCallingConvention :: String -> TypeEnv -> Env -> Ty -> (String, Ty) +memberStrCallingConvention strOrPrn typeEnv globalEnv memberTy = + if callWithValue + then ("", withValueSig) + else ("&", withRefSig) + where + withValueSig = FuncTy [memberTy] StringTy StaticLifetimeTy + withRefSig = FuncTy [RefTy memberTy (VarTy "w")] StringTy StaticLifetimeTy -- "w" here is dubious? + callWithValue = + -- If these interfaces are not implemented we assume ref signature is fine. + -- Blitable is required to not accicentally pass a value owned by the struct to + -- a non-ref str/prn function implemented on one of its memeber types. + let blitable = interfaceImplementedForTy typeEnv globalEnv "blit" (FuncTy [memberTy] memberTy StaticLifetimeTy) + strTakesValue = interfaceImplementedForTy typeEnv globalEnv strOrPrn withValueSig + in blitable && strTakesValue -- | Generate C code for converting a member variable to a string and appending it to a buffer. memberPrn :: TypeEnv -> Env -> (String, Ty) -> String memberPrn typeEnv env (memberName, memberTy) = - let (_, maybeTakeAddress, strFuncType) = memberInfo typeEnv memberTy + let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of Just strFunctionPath -> case strFuncType of @@ -26,27 +40,18 @@ memberPrn typeEnv env (memberName, memberTy) = ] _ -> unlines - [ " temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ ");", + [ " temp = " ++ pathToC strFunctionPath ++ "(" ++ prefix ++ "p->" ++ memberName ++ ");", " sprintf(bufferPtr, \"%s \", temp);", " bufferPtr += strlen(temp) + 1;", " if(temp) { CARP_FREE(temp); temp = NULL; }" ] Nothing -> - if isExternalType typeEnv memberTy - then - unlines - [ " temp = malloc(11);", - " sprintf(temp, \"\");", - " sprintf(bufferPtr, \"%s \", temp);", - " bufferPtr += strlen(temp) + 1;", - " if(temp) { CARP_FREE(temp); temp = NULL; }" - ] - else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n" + " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n" -- | Calculate the size for prn:ing a member of a struct memberPrnSize :: TypeEnv -> Env -> (String, Ty) -> String memberPrnSize typeEnv env (memberName, memberTy) = - let (_, maybeTakeAddress, strFuncType) = memberInfo typeEnv memberTy + let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of Just strFunctionPath -> case strFuncType of @@ -58,15 +63,9 @@ memberPrnSize typeEnv env (memberName, memberTy) = ] _ -> unlines - [ " temp = " ++ pathToC strFunctionPath ++ "(" ++ maybeTakeAddress ++ "p->" ++ memberName ++ "); ", + [ " temp = " ++ pathToC strFunctionPath ++ "(" ++ prefix ++ "p->" ++ memberName ++ "); ", " size += snprintf(NULL, 0, \"%s \", temp);", " if(temp) { CARP_FREE(temp); temp = NULL; }" ] Nothing -> - if isExternalType typeEnv memberTy - then - unlines - [ " size += 11;", - " if(temp) { CARP_FREE(temp); temp = NULL; }" - ] - else " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n" + " // Failed to find str function for " ++ memberName ++ " : " ++ show memberTy ++ "\n" diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 842a61bf..2339b7d2 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -172,8 +172,8 @@ concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy ty ) ( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) -> concatMap - (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) - (filter (\t -> (not . isExternalType typeEnv) t && (not . isFullyGenericType) t) (concatMap caseTys cases)) + (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) + (remove isFullyGenericType (concatMap caseTys cases)) ) concreteStr _ _ _ _ _ _ = error "concretestr" @@ -200,8 +200,8 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) ca ( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy correctedCases = replaceGenericTypesOnCases mappings cases - tys = filter (\t' -> (not . isExternalType typeEnv) t' && (not . isFullyGenericType) t') (concatMap caseTys correctedCases) - in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv) tys + tys = remove isFullyGenericType (concatMap caseTys correctedCases) + in concatMap (depsOfPolymorphicFunction typeEnv env [] "prn" . typesStrFunctionType typeEnv env) tys ++ (if isTypeGeneric concreteStructTy then [] else [defineFunctionTypeAlias ft]) ) genericStr _ _ _ _ = error "genericstr" @@ -302,7 +302,7 @@ genericSumtypeDelete pathStrings originalStructTy cases = else concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv) (concatMap caseTys correctedCases)) + (filter (isManaged typeEnv env) (concatMap caseTys correctedCases)) ) -- | The template for the 'delete' function of a concrete sumtype @@ -327,7 +327,7 @@ concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy ( \_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "delete" . typesDeleterFunctionType) - (filter (isManaged typeEnv) (concatMap caseTys cases)) + (filter (isManaged typeEnv env) (concatMap caseTys cases)) ) concreteSumtypeDelete _ _ _ _ _ = error "concretesumtypedelete" @@ -376,7 +376,7 @@ genericSumtypeCopy pathStrings originalStructTy cases = else concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv) (concatMap caseTys correctedCases)) + (filter (isManaged typeEnv env) (concatMap caseTys correctedCases)) ) -- | The template for the 'copy' function of a concrete sumtype @@ -393,7 +393,7 @@ concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy ty ( \_ -> concatMap (depsOfPolymorphicFunction typeEnv env [] "copy" . typesCopyFunctionType) - (filter (isManaged typeEnv) (concatMap caseTys cases)) + (filter (isManaged typeEnv env) (concatMap caseTys cases)) ) concreteSumtypeCopy _ _ _ _ _ = error "concretesumtypecopy" diff --git a/src/Validate.hs b/src/Validate.hs index bb30aa71..8f44cca5 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -5,7 +5,6 @@ import Data.Function (on) import Data.List (nubBy, (\\)) import Data.Maybe (fromJust) import Lookup -import Managed import Obj import TypeError import TypePredicates @@ -66,45 +65,43 @@ okXObjForType typeEnv typeVariables xobj = -- | Can this type be used as a member for a deftype? canBeUsedAsMemberType :: TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError () canBeUsedAsMemberType typeEnv typeVariables ty xobj = - if isExternalType typeEnv ty - then pure () - else case ty of - UnitTy -> pure () - IntTy -> pure () - FloatTy -> pure () - DoubleTy -> pure () - ByteTy -> pure () - LongTy -> pure () - BoolTy -> pure () - StringTy -> pure () - PatternTy -> pure () - CharTy -> pure () - FuncTy {} -> pure () - PointerTy UnitTy -> pure () - PointerTy inner -> - canBeUsedAsMemberType typeEnv typeVariables inner xobj - >> pure () - -- Struct variables may appear as complete applications or individual - -- components in the head of a definition; that is the forms: - -- ((Foo (f a b)) [x (f a b)]) - -- ((Foo f a b) [x f y a z b]) - -- are both valid, but restrict their types differently. In the former, - -- `f` may only appear in complete applications over `a` and `b`, in - -- other words, `f` is closed over `a` and `b`. In the latter, f may - -- flexibly be used as a type variable of nullary kind, or as a type - -- variable of unary kind `(Foo f a b) [x (f a) y (f b)])` so long as - -- the kinds of each occasion of `f` are consistent. - -- - -- Likewise, the types denoted by: - -- ((Foo (f a) b) ...) - -- and - -- ((Foo (f a) (f b)) ...) - -- differ. - -- Attempt the first, more restrictive formulation first. - struct@(StructTy name tyVars) -> - checkVar struct <> checkStruct name tyVars - v@(VarTy _) -> checkVar v - _ -> Left (InvalidMemberType ty xobj) + case ty of + UnitTy -> pure () + IntTy -> pure () + FloatTy -> pure () + DoubleTy -> pure () + ByteTy -> pure () + LongTy -> pure () + BoolTy -> pure () + StringTy -> pure () + PatternTy -> pure () + CharTy -> pure () + FuncTy {} -> pure () + PointerTy UnitTy -> pure () + PointerTy inner -> + canBeUsedAsMemberType typeEnv typeVariables inner xobj + >> pure () + -- Struct variables may appear as complete applications or individual + -- components in the head of a definition; that is the forms: + -- ((Foo (f a b)) [x (f a b)]) + -- ((Foo f a b) [x f y a z b]) + -- are both valid, but restrict their types differently. In the former, + -- `f` may only appear in complete applications over `a` and `b`, in + -- other words, `f` is closed over `a` and `b`. In the latter, f may + -- flexibly be used as a type variable of nullary kind, or as a type + -- variable of unary kind `(Foo f a b) [x (f a) y (f b)])` so long as + -- the kinds of each occasion of `f` are consistent. + -- + -- Likewise, the types denoted by: + -- ((Foo (f a) b) ...) + -- and + -- ((Foo (f a) (f b)) ...) + -- differ. + -- Attempt the first, more restrictive formulation first. + struct@(StructTy name tyVars) -> + checkVar struct <> checkStruct name tyVars + v@(VarTy _) -> checkVar v + _ -> Left (InvalidMemberType ty xobj) where checkStruct :: Ty -> [Ty] -> Either TypeError () checkStruct (ConcreteNameTy "Array") [innerType] = @@ -112,6 +109,8 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj = >> pure () checkStruct (ConcreteNameTy n) vars = case lookupBinder (SymPath [] n) (getTypeEnv typeEnv) of + Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> + pure () Just (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars Just (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> diff --git a/test/init_global.carp b/test/init_global.carp index 73818c83..9c6f1468 100644 --- a/test/init_global.carp +++ b/test/init_global.carp @@ -7,5 +7,6 @@ ;; The one allocation left after 'carp_init_globals' should be 'g' itself: (defn main [] (do + (Debug.log-memory-balance! true) (assert (= 1l (Debug.memory-balance))) 0)) diff --git a/test/managed.carp b/test/managed.carp new file mode 100644 index 00000000..83ae2e7b --- /dev/null +++ b/test/managed.carp @@ -0,0 +1,66 @@ +(load-and-use Test) + +(defn assert-memory-balance [state f expected-balance descr] + (do + (Debug.reset-memory-balance!) + (f) + (assert-equal state expected-balance (Debug.memory-balance) descr))) + +(register-type A "void*") +(register-type B "void*") + +(defmodule A + (deftemplate init (Fn [] A) + "void* $NAME()" "$DECL { return CARP_MALLOC(128); }") + + (deftemplate copy (Fn [&A] A) + "void* $NAME(void **p)" "$DECL { return CARP_MALLOC(128); }") + (implements copy A.copy) + + (deftemplate delete (Fn [A] ()) + "void $NAME(void *p)" "$DECL { CARP_FREE(p); }") + (implements delete A.delete)) + +(defmodule B + (deftemplate init (Fn [] B) + "void* $NAME()" "$DECL { return CARP_MALLOC(128); }") + + (deftemplate copy (Fn [&B] B) + "void* $NAME(void **p)" "$DECL { return CARP_MALLOC(128); }") + (implements copy B.copy) + + ;; 'B' does *not* implement delete! + ;; The user would have to call delete / free on it manually to avoid a leak. + ) + +(defn f-a [] + (let [a (A)] + ())) + +(defn f-b [] + (let [b (B)] + ())) + +(defn f-copy-a [] + (let [a (A) + a2 @&a] + ())) + +(defn f-copy-b [] + (let [b (B) + b2 @&b] + ())) + +(eval ;; temporary workaround to force evaluation of top-level 'when' + (when (not (managed? A)) + (macro-error "Fail - A should be managed."))) + +(eval + (when (managed? B) + (macro-error "Fail - B should not be managed."))) + +(deftest test + (assert-memory-balance test f-a 0l "f-a correct, does not leak") + (assert-memory-balance test f-b 1l "f-b correct, leaks 1 value") + (assert-memory-balance test f-copy-a 0l "f-copy-a correct, does not leak") + (assert-memory-balance test f-copy-b 2l "f-copy-b correct, leaks 2 values")) diff --git a/test/statistics.carp b/test/statistics.carp index 0c422223..19dea44c 100644 --- a/test/statistics.carp +++ b/test/statistics.carp @@ -4,7 +4,7 @@ (use-all Double Test Statistics) (defn all-eq [a b] - (if (Int./= (Array.length a) (Array.length b)) + (if (/= (Array.length a) (Array.length b)) false (let [res true] (do @@ -15,7 +15,7 @@ res)))) (defn all-approx [a b] - (if (Int./= (Array.length a) (Array.length b)) + (if (/= (Array.length a) (Array.length b)) false (let [res true] (do