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

@@ -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))

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")

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

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)
 

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]

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,

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]

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"

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

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

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? <sym>)` 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"

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 <optional: c-name> <optional: members>)" 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")

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, \"<external>\");",
-                  "  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"

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"
 

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) _ _ : _)) _ _)) ->

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))

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"))

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