feat: register-type improvements (#1332)

* fix: don't instantiate dummy fields for external types For ANSI C compatibility reasons, we add a dummy field for memberless types defined in Carp (see commit 59ef5bbf2b). When registering a type with no fields, `(register-type A [])`, we'd also attempt to set our dummy field in the Carp generated initializer for the type. However, the registered type is totally opaque from the perspective of Carp, and we can't assume it has a field corresponding to our dummy field. This commit changes our handling of __dummy in initializers to avoid setting it for registered types. * feat: automatically implement str and prn for registered types This commit makes the auto-generated str and prn functions for registered types implement the str and prn interfaces, removing the need for users to call implements on these functions explicitly. It alters the signature of `autoDerive` in Primitives.hs slightly to make it more flexible (since registered types have no delete or copy functions that we can add to the implementation lists of these interfaces). * docs: add docs on register-type to CInterop.md The new documentation clarifies the usage of `register-type` and accounts for the changes in the prior two commits. * fix: fix function signatures for generic memberless initers Filter out dummy field arguments. * docs: Add details about type name overrides to CInterop.md * docs: clarify that users can implement delete for registered types
2024-09-11 05:25:28 +03:00 · 2021-10-18 10:48:02 -04:00 · 2021-10-18 10:48:02 -04:00 · f4bcc28fc0
commit f4bcc28fc0
parent 102181d244
3 changed files with 161 additions and 24 deletions
--- a/docs/CInterop.md
+++ b/docs/CInterop.md
@ -14,6 +14,7 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide.
    - [`Generics`](#generics)
  - [`emit-c`](#unsafe-emit-c)
  - [`preproc`](#unsafe-preproc)
+  - [Registering Types](#register-types)
 - [Callbacks](#callbacks)


@ -409,6 +410,113 @@ in compiler output. If your helper functions, macros, or preprocessor
 directives are lengthy or complex, you may want to define them in a separate
 `h` file and `relative-include` it in your Carp source instead.

+### Registering Types
+
+Carp supports a few different ways of registering types defined in C. You can
+register types using the `register-type` function. Calling `register-type` with
+only a symbol argument registers the C type with a name corresponding to the
+symbol.  For example, the following code registers the C type `A` as the type
+`A` in Carp.
+
+```c
+typedef int A;
+```
+
+```clojure
+(register-type A)
+```
+
+After this call to `register-type`, you can use the type `A` anywhere type
+names are valid in Carp code. For example, you can use it in function
+signatures:
+
+```clojure
+(sig a-prn (Fn [A] String))
+```
+
+The prior type registration *only* registers the type name in Carp. In other
+words, the type is entirely "opaque" from the perspective of your Carp program.
+Carp knows the type exists, but it knows nothing about its implementation or
+how to construct values of the type--all of that is left up to your C code.
+
+If you want to construct values of this type from Carp code, you have two
+options:
+
+1. You can define your own initializers for the type in C and register them in Carp.
+2. You can use `register-type` to generate initializers for the type in Carp.
+
+If you define an initializer for the type in C, you can access it from Carp by
+using `register`:
+
+```c
+typedef int A;
+
+A initializer() {
+  return 0;
+}
+```
+
+```clojure
+(register-type A)
+(register initializer (Fn [] A))
+;; returns a value of type A
+(initializer)
+```
+
+Alternatively, you can add a non-empty array of type members in your
+`register-type` call to have Carp generate initializers, getters and setters,
+and printing functions for the external type. The initializer Carp generates
+will only initialize the fields you specify. If you omit or misname a field,
+the generated initializer might cause errors.
+
+```clojure
+(register-type B [])
+:i B
+=> B : Type
+     init : (Fn [] B)
+     prn  : (Fn [(Ref B q)] String)
+     str  : (Fn [(Ref B q)] String)
+}
+(register-type C [x Int])
+:i C
+=> C : Type
+   C : Module {
+     init     : (Fn [Int] C)
+     prn      : (Fn [(Ref C q) String])
+     str      : (Fn [(Ref C q) String])
+     set-x    : (Fn [C, Int] C)
+     set-x!   : (Fn [(Ref C q), Int] ())
+     update-x : (Fn [C, (Ref (Fn [Int] Int) q)] C)
+     x        : (Fn [(Ref C q)] (Ref Int q))
+}
+```
+
+The `prn` and `str` functions for the type will also automatically implement
+their corresponding interfaces.
+
+Be mindful that Carp *does not manage the memory associated with external types
+by default!* Unlike types defined in Carp, Carp will not generate `copy` and
+`delete` functions for registered types. If you use generated initializers for
+a registered type for convenience, remember that you still need to manage the
+memory associated with values of the type manually. If you want Carp to manage
+the memory for a registered type, you can provide implementations of the `copy`
+and `delete` interfaces.
+
+If needed, you can override the name Carp emits for a registered type by
+providing an additional string argument. This comes in handy when the type's
+name in C does not follow lisp or Carp naming conventions. For example, the
+type in C might begin with a lowercase letter, while Carp requires all types to
+begin with uppercase letters:
+
+```clojure
+;; Emitted in C code as "A"
+(register-type A)
+;; Emitted in C code a "a_type"
+(register-type A "a_type")
+;; Emitted in C code as "b_type"
+(register-type B "b_type" [x Int])
+```
+
 ## Callbacks

 Some C APIs rely on callbacks, let's define a C function that accepts a
--- a/src/Deftype.hs
+++ b/src/Deftype.hs
@ -59,11 +59,17 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
      -- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
      -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
      insidePath = pathStrings ++ [typeName]
+      initmembers = case rest of
+                      -- ANSI C does not allow empty structs. We add a dummy member here to account for this.
+                      -- Note that we *don't* add this member for external types--we leave those definitions up to the user.
+                      -- The corresponding field is emitted for the struct definition in Emit.hs
+                      [(XObj (Arr []) ii t)] -> [(XObj (Arr [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)]) ii t)]
+                      _ -> rest
   in do
        validateMemberCases typeEnv env typeVariables rest
        let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
        (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
-        okInit <- binderForInit insidePath structTy rest
+        okInit <- binderForInit insidePath structTy initmembers
        (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
        (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
        (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
@ -336,15 +342,21 @@ templateUpdater member _ =
 -- | Helper function to create the binder for the 'init' template.
 binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
 binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
-  if isTypeGeneric structTy
-    then Right (genericInit StackAlloc insidePath structTy membersXObjs)
-    else
-      Right $
-        instanceBinder
-          (SymPath insidePath "init")
-          (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
-          (concreteInit StackAlloc structTy membersXObjs)
-          ("creates a `" ++ show structTy ++ "`.")
+  -- Remove the __dummy field from the members array to ensure we can call the initializer with no arguments.
+  -- See the implementation of moduleForDeftype for more details.
+  let nodummy = case membersXObjs of
+                  [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)] -> []
+                  _ -> membersXObjs
+   in if isTypeGeneric structTy
+        then Right (genericInit StackAlloc insidePath structTy membersXObjs)
+        else
+          Right $
+            instanceBinder
+              (SymPath insidePath "init")
+              -- don't include the dummy field in arg lists
+              (FuncTy (initArgListTypes nodummy) structTy StaticLifetimeTy)
+              (concreteInit StackAlloc structTy membersXObjs)
+              ("creates a `" ++ show structTy ++ "`.")
 binderForInit _ _ _ = error "binderforinit"

 -- | Generate a list of types from a deftype declaration.
@ -361,7 +373,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) mem
        let mappings = unifySignatures originalStructTy concreteStructTy
            correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
            memberPairs = memberXObjsToPairs correctedMembers
-         in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")")
+         in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (unitless memberPairs))) ++ ")")
    )
    ( \(FuncTy _ concreteStructTy _) ->
        let mappings = unifySignatures originalStructTy concreteStructTy
@ -371,6 +383,9 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) mem
    (\FuncTy {} -> [])
  where
    unitless = remove (isUnit . snd)
+    nodummy  = remove (isDummy . fst)
+    isDummy "__dummy" = True
+    isDummy _ = False
 concreteInit _ _ _ = error "concreteinit"

 -- | The template for the 'init' and 'new' functions for a generic deftype.
@ -379,7 +394,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
  defineTypeParameterizedTemplate templateCreator path t docs
  where
    path = SymPath pathStrings "init"
-    t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
+    t = FuncTy (map snd (nodummy (memberXObjsToPairs membersXObjs))) originalStructTy StaticLifetimeTy
    docs = "creates a `" ++ show originalStructTy ++ "`."
    templateCreator = TemplateCreator $
      \typeEnv env ->
@ -389,7 +404,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
              let mappings = unifySignatures originalStructTy concreteStructTy
                  correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
                  memberPairs = memberXObjsToPairs correctedMembers
-               in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")")
+               in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (remove (isUnit . snd) memberPairs))) ++ ")")
          )
          ( \(FuncTy _ concreteStructTy _) ->
              let mappings = unifySignatures originalStructTy concreteStructTy
@ -401,6 +416,9 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
                Left _ -> []
                Right ok -> ok
          )
+    nodummy  = remove (isDummy . fst)
+    isDummy "__dummy" = True
+    isDummy _ = False
 genericInit _ _ _ _ = error "genericinit"

 tokensForInit :: AllocationMode -> String -> [XObj] -> [Token]
@ -421,7 +439,7 @@ tokensForInit allocationMode typeName membersXObjs =
        "}"
      ]
  where
-    assignments [] = "    instance.__dummy = 0;"
+    assignments [] = ""
    assignments _ = go unitless
      where
        go [] = ""
@ -537,9 +555,13 @@ calculateStructStrSize typeEnv env members s@(StructTy (ConcreteNameTy _) _) =
 calculateStructStrSize _ _ _ _ = error "calculatestructstrsize"

 -- | Generate C code for assigning to a member variable.
-- | Needs to know if the instance is a pointer or stack variable.
+-- Needs to know if the instance is a pointer or stack variable.
+-- Also handles the special dummy member we add for empty structs to be ANSI C compatible.
 memberAssignment :: AllocationMode -> String -> String
-memberAssignment allocationMode memberName = "    instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
+memberAssignment allocationMode memberName =
+  case memberName of
+    "__dummy" -> "    instance" ++ sep ++ memberName ++ " = " ++ "0" ++ ";"
+    _ -> "    instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
  where
    sep = case allocationMode of
      StackAlloc -> "."
--- a/src/Primitives.hs
+++ b/src/Primitives.hs
@ -263,7 +263,10 @@ primitiveRegisterTypeWithFields ctx x t override members =
            Right ctx' = update ctx
        -- TODO: Another case where define does not get formally qualified deps!
        contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps)
-        pure (contextWithDefs, dynamicNil)
+        autoDerive contextWithDefs (StructTy (ConcreteNameTy (unqualify path')) [])
+          [ lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "str")),
+            lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "prn"))
+          ]
    path = SymPath [] t
    preExistingModule = case lookupBinderInGlobalEnv ctx path of
      Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et)
@ -612,6 +615,10 @@ deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor =
    case e of
      Left err -> pure (evalError ctx (show err) (xobjInfo x))
      Right t -> autoDerive ctxWithType t
+        [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
+          lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
+          lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
+        ]
 deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor =
  do
    (ctxWithType, e) <-
@ -623,6 +630,10 @@ deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) c
    case e of
      Left err -> pure (evalError ctx (show err) (xobjInfo x))
      Right t -> autoDerive ctxWithType t
+        [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
+          lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
+          lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
+        ]
 deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name)

 checkVariables :: [XObj] -> Maybe [Ty]
@ -658,21 +669,17 @@ unwrapTypeErr ctx (Left err) = Left (typeErrorToString ctx err)
 unwrapTypeErr _ (Right x) = Right x

 -- | Automatically derive implementations of interfaces.
-autoDerive :: Context -> Ty -> IO (Context, Either EvalError XObj)
-autoDerive c ty =
+autoDerive :: Context -> Ty -> [Either ContextError Binder] -> IO (Context, Either EvalError XObj)
+autoDerive c ty interfaces =
  let (SymPath mods tyname) = (getStructPath ty)
      implBinder :: String -> Ty -> Binder
      implBinder name t = Binder emptyMeta (XObj (Sym (SymPath (mods ++ [tyname]) name) Symbol) (Just dummyInfo) (Just t))
      getSig :: String -> Ty
      getSig "delete" = FuncTy [ty] UnitTy StaticLifetimeTy
      getSig "str" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy
+      getSig "prn" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy
      getSig "copy" = FuncTy [RefTy ty (VarTy "q")] ty StaticLifetimeTy
      getSig _ = VarTy "z"
-      interfaces =
-        [ lookupBinderInTypeEnv c (markQualified (SymPath [] "delete")),
-          lookupBinderInTypeEnv c (markQualified (SymPath [] "str")),
-          lookupBinderInTypeEnv c (markQualified (SymPath [] "copy"))
-        ]
      registration interface =
        let name = getSimpleName (binderXObj interface)
            sig = getSig name