Skip to content

Commit 380945b

Browse files
scolsenhellerveeriksvedangTimDeve
authored
feat: add box type (#1358)
* feat: add box templates and box type This commit adds an implementation of Boxes, memory manged heap allocated values. Boxes are implemented as C pointers, with no additional structure but are treated as structs in Carp. To facilitate this, we need to add them as a clause to our special type emissions (TypesToC) as they'd otherwise be emitted like other struct types. Co-authored-by: Veit Heller <[email protected]> * fix: slight memory management fix for Box Make sure we free the box! * test: add tests for box (including memory checks) * Revert "fix: Ignore clang nitpick" This reverts commit 70ec6d4. * fix: update example/functor.carp Now that a builtin type named Box exists, the definitions in this file cause a conflict. I've renamed the "Box" type in the functor example to remove the conflict. * feat: add Box.peek Box.peek allows users to transform a reference to a box into a a reference to the box's contained value. The returned reference will have the same lifetime as the box. This function allows callers to manipulate the value in a box without re-allocation, for example: ```clojure (deftype Num [val Int]) (let-do [box (Box.init (Num.init 0))] (Num.set-val! (Box.peek &box) 1) @(Num.val (Box.peek &box))) ``` This commit also includes tests for Box.peek. Co-authored-by: TimDeve <[email protected]> Co-authored-by: Veit Heller <[email protected]> Co-authored-by: Erik Svedäng <[email protected]> Co-authored-by: TimDeve <[email protected]>
1 parent a7e1115 commit 380945b

9 files changed

+315
-12
lines changed

‎CarpHask.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ library
1818
hs-source-dirs: src
1919
exposed-modules: ArrayTemplates,
2020
AssignTypes,
21+
BoxTemplates,
2122
ColorText,
2223
Commands,
2324
Concretize,

‎core/Box.carp

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
(defmodule Box
2+
(defn = [box-a box-b]
3+
(= (Box.unbox @box-a) (Box.unbox @box-b)))
4+
(implements = =)
5+
)

‎core/Core.carp

+1
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@
1818
(load-once "Interfaces.carp")
1919
(load-once "Blitable.carp")
2020
(load-once "Bool.carp")
21+
(load-once "Box.carp")
2122
(load-once "Macros.carp")
2223
(load-once "BoolExtras.carp")
2324
(load-once "List.carp")

‎examples/functor.carp

+8-8
Original file line numberDiff line numberDiff line change
@@ -10,14 +10,14 @@
1010
(implements fmap ArrayExtension.fmap)
1111
)
1212

13-
(deftype (Box a) [x a])
13+
(deftype (MyBox a) [x a])
1414

15-
(defmodule Box
16-
(defn fmap [f box] (let [new-x (~f @(Box.x &box))]
17-
(Box.set-x box new-x)))
18-
(implements fmap Box.fmap))
15+
(defmodule MyBox
16+
(defn fmap [f box] (let [new-x (~f @(MyBox.x &box))]
17+
(MyBox.set-x box new-x)))
18+
(implements fmap MyBox.fmap))
1919

20-
(use Box)
20+
(use MyBox)
2121
(use ArrayExtension)
2222

2323
;; TODO: This function currently concretizes to the type of the first (f *) it
@@ -29,8 +29,8 @@
2929

3030
(defn main []
3131
(do
32-
(println &(str @(Box.x &(fmap &Int.inc (Box.init 100)))))
33-
(println &(str @(Box.x &(Box.fmap &inc (Box.init 100)))))
32+
(println &(str @(MyBox.x &(fmap &Int.inc (MyBox.init 100)))))
33+
(println &(str @(MyBox.x &(MyBox.fmap &inc (MyBox.init 100)))))
3434
(println &(str &(ArrayExtension.fmap &inc [10 20 30 40 50])))
3535
(println &(str &(fmap &Int.inc [10 20 30 40 50])))
3636
(println &(Array.str &(fmap &Int.inc [10 20 30 40 50])))

‎src/BoxTemplates.hs

+237
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,237 @@
1+
-- | Module BoxTemplates defines Carp's Box type, a container for managed,
2+
-- heap allocated objects.
3+
module BoxTemplates
4+
( delete,
5+
str,
6+
prn,
7+
BoxTemplates.init,
8+
copy,
9+
unbox,
10+
peek,
11+
)
12+
where
13+
14+
import Concretize
15+
import Obj
16+
import Polymorphism
17+
import Template
18+
import ToTemplate
19+
import Types
20+
21+
boxTy :: Ty
22+
boxTy = StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]
23+
24+
-- | Defines a template for initializing Boxes.
25+
init :: (String, Binder)
26+
init = let path = SymPath ["Box"] "init"
27+
t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy
28+
docs = "Initializes a box pointing to value t."
29+
decl = templateLiteral "$t* $NAME ($t t)"
30+
body = const (multilineTemplate
31+
[ "$DECL {",
32+
" $t* instance;",
33+
" instance = CARP_MALLOC(sizeof($t));",
34+
" *instance = t;",
35+
" return instance;",
36+
"}"
37+
])
38+
deps = const []
39+
template = TemplateCreator $ \_ _ -> Template t decl body deps
40+
in defineTypeParameterizedTemplate template path t docs
41+
42+
-- | Defines a template for converting a boxed value to a local value.
43+
unbox :: (String, Binder)
44+
unbox = let path = SymPath ["Box"] "unbox"
45+
t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy
46+
docs = "Converts a boxed value to a reference to the value and delete the box."
47+
decl = templateLiteral "$t $NAME($t* box)"
48+
body = const (multilineTemplate
49+
[ "$DECL {",
50+
" $t local;",
51+
" local = *box;",
52+
" CARP_FREE(box);",
53+
" return local;",
54+
"}"
55+
])
56+
deps = const []
57+
template = TemplateCreator $ \_ _ -> Template t decl body deps
58+
in defineTypeParameterizedTemplate template path t docs
59+
60+
-- | Defines a template for getting a reference to the value stored in a box without performing an additional allocation.
61+
peek :: (String, Binder)
62+
peek = let path = SymPath ["Box"] "peek"
63+
t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy
64+
docs = "Returns a reference to the value stored in a box without performing an additional allocation."
65+
decl = templateLiteral "$t* $NAME($t** box_ref)"
66+
body = const (multilineTemplate
67+
[ "$DECL {",
68+
" return *box_ref;",
69+
"}"
70+
])
71+
deps = const []
72+
template = TemplateCreator $ \_ _ -> Template t decl body deps
73+
in defineTypeParameterizedTemplate template path t docs
74+
75+
-- | Defines a template for copying a box. The copy will also be heap allocated.
76+
copy :: (String, Binder)
77+
copy =
78+
let path = SymPath ["Box"] "copy"
79+
t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) StaticLifetimeTy
80+
docs = "Copies a box."
81+
decl = (templateLiteral "$t* $NAME ($t** box)")
82+
template = TemplateCreator $
83+
\tenv env ->
84+
Template
85+
t
86+
decl
87+
( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) ->
88+
innerCopy tenv env inner
89+
)
90+
( \(FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) ->
91+
depsForCopyFunc tenv env inner
92+
++ depsForDeleteFunc tenv env boxType
93+
)
94+
in defineTypeParameterizedTemplate template path t docs
95+
where
96+
innerCopy typeEnv valEnv innerTy =
97+
case findFunctionForMemberIncludePrimitives typeEnv valEnv "copy" (typesCopyFunctionType innerTy) ("Inside box.", innerTy) of
98+
FunctionFound functionFullName ->
99+
multilineTemplate
100+
[ "$DECL {",
101+
" $t* copy;",
102+
" copy = CARP_MALLOC(sizeof($t));",
103+
" *copy = " ++ functionFullName ++ "(*box);",
104+
" return copy;",
105+
"}"
106+
]
107+
_ ->
108+
multilineTemplate
109+
[ "$DECL {",
110+
" $t* copy;",
111+
" copy = CARP_MALLOC(sizeof($t));",
112+
" *copy = *box;",
113+
" return copy;",
114+
"}"
115+
]
116+
117+
-- | Defines a template for deleting a box.
118+
delete :: (String, Binder)
119+
delete =
120+
let path = SymPath ["Box"] "delete"
121+
t = FuncTy [boxTy] UnitTy StaticLifetimeTy
122+
docs = "Deletes a box, freeing its associated memory."
123+
decl = (templateLiteral "void $NAME ($t* box)")
124+
templateCreator = TemplateCreator $
125+
\tenv env ->
126+
Template
127+
t
128+
decl
129+
( \(FuncTy [bTy] UnitTy _) ->
130+
multilineTemplate
131+
[ "$DECL {",
132+
" " ++ innerDelete tenv env bTy,
133+
"}"
134+
]
135+
)
136+
( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) ->
137+
depsForDeleteFunc tenv env insideType
138+
)
139+
in defineTypeParameterizedTemplate templateCreator path t docs
140+
where
141+
innerDelete :: TypeEnv -> Env -> Ty -> String
142+
innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) =
143+
case findFunctionForMember tenv env "delete" (typesDeleterFunctionType inner) ("Inside box.", inner) of
144+
FunctionFound functionFullName ->
145+
" " ++ functionFullName ++ "(*box);\n"
146+
++ " CARP_FREE(box);"
147+
FunctionNotFound msg -> error msg
148+
FunctionIgnored ->
149+
" /* Ignore non-managed type inside Box: '" ++ show inner ++ "' */\n"
150+
++ " CARP_FREE(box);"
151+
innerDelete _ _ _ = ""
152+
153+
-- | Defines a template for printing a box as a string.
154+
prn :: (String, Binder)
155+
prn =
156+
let path = SymPath ["Box"] "prn"
157+
t = FuncTy [boxTy] StringTy StaticLifetimeTy
158+
docs = "Returns a string representation of a Box."
159+
decl = templateLiteral "String $NAME ($t* box)"
160+
templateCreator =
161+
TemplateCreator $
162+
( \tenv env ->
163+
Template
164+
t
165+
decl
166+
( \(FuncTy [boxT] StringTy _) ->
167+
multilineTemplate
168+
[ "$DECL {",
169+
" if(!box){",
170+
" String buffer = CARP_MALLOC(4);",
171+
" sprintf(buffer, \"Nil\");",
172+
" return buffer;",
173+
" }",
174+
innerStr tenv env boxT,
175+
" return buffer;",
176+
"}"
177+
]
178+
)
179+
( \(FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) ->
180+
depsForPrnFunc tenv env inner
181+
)
182+
)
183+
in defineTypeParameterizedTemplate templateCreator path t docs
184+
185+
-- | Defines a template for printing a reference to a box as a string.
186+
str :: (String, Binder)
187+
str =
188+
let path = SymPath ["Box"] "str"
189+
t = FuncTy [(RefTy boxTy (VarTy "q"))] StringTy StaticLifetimeTy
190+
docs = "Returns a string representation of a Box."
191+
templateCreator =
192+
TemplateCreator $
193+
( \tenv env ->
194+
Template
195+
t
196+
(templateLiteral "String $NAME ($t** box)")
197+
( \(FuncTy [RefTy boxT _] StringTy _) ->
198+
multilineTemplate
199+
[ "$DECL {",
200+
" if(!box){",
201+
" String buffer = CARP_MALLOC(4);",
202+
" sprintf(buffer, \"Nil\");",
203+
" return buffer;",
204+
" }",
205+
innerStr tenv env boxT,
206+
" return buffer;",
207+
"}"
208+
]
209+
)
210+
( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) ->
211+
depsForPrnFunc tenv env inner
212+
)
213+
)
214+
in defineTypeParameterizedTemplate templateCreator path t docs
215+
216+
innerStr :: TypeEnv -> Env -> Ty -> String
217+
innerStr tenv env (StructTy _ [t]) =
218+
case findFunctionForMemberIncludePrimitives tenv env "prn" (typesStrFunctionType tenv env (RefTy t StaticLifetimeTy)) ("Inside box.", t) of
219+
FunctionFound functionFullName ->
220+
unlines
221+
[ " char* temp = " ++ functionFullName ++ "(*box);",
222+
" int size = snprintf(NULL, 0, \"(Box %s)\", temp);",
223+
" String buffer = CARP_MALLOC(size);",
224+
" sprintf(buffer, \"(Box %s)\", temp);",
225+
" if(temp) {",
226+
" CARP_FREE(temp);",
227+
" temp = NULL;",
228+
" }"
229+
]
230+
FunctionNotFound _ ->
231+
unlines
232+
[ " String buffer = CARP_MALLOC(14);",
233+
" sprintf(buffer, \"(Box unknown)\");"
234+
]
235+
FunctionIgnored -> " /* Ignore type inside Box: '" ++ show t ++ "' ??? */\n"
236+
innerStr _ _ _ = ""
237+

‎src/StartingEnv.hs

+28-4
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ import qualified StaticArrayTemplates
1414
import Template
1515
import ToTemplate
1616
import Types
17+
import qualified BoxTemplates
1718

1819
-- | These modules will be loaded in order before any other code is evaluated.
1920
coreModules :: String -> [String]
@@ -108,6 +109,28 @@ templatePointerCopy =
108109
)
109110
(const [])
110111

112+
-- | The Box module contains functions for working with Boxes (pointers to heap allocated values).
113+
boxModule :: Env
114+
boxModule =
115+
Env
116+
{ envBindings = bindings,
117+
envParent = Nothing,
118+
envModuleName = Just "Box",
119+
envUseModules = Set.empty,
120+
envMode = ExternalEnv,
121+
envFunctionNestingLevel = 0
122+
}
123+
where
124+
bindings = Map.fromList
125+
[ BoxTemplates.init,
126+
BoxTemplates.unbox,
127+
BoxTemplates.peek,
128+
BoxTemplates.delete,
129+
BoxTemplates.copy,
130+
BoxTemplates.prn,
131+
BoxTemplates.str
132+
]
133+
111134
maxArity :: Int
112135
maxArity = 9
113136

@@ -506,6 +529,7 @@ startingGlobalEnv noArray =
506529
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule E.empty) Nothing Nothing))]
507530
++ [("Function", Binder emptyMeta (XObj (Mod functionModule E.empty) Nothing Nothing))]
508531
++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule E.empty) Nothing Nothing))]
532+
++ [("Box", Binder emptyMeta (XObj (Mod boxModule E.empty) Nothing Nothing))]
509533

510534
-- | The type environment (containing deftypes and interfaces) before any code is run.
511535
startingTypeEnv :: Env
@@ -524,22 +548,22 @@ startingTypeEnv =
524548
[ interfaceBinder
525549
"delete"
526550
(FuncTy [VarTy "a"] UnitTy StaticLifetimeTy)
527-
([SymPath ["Array"] "delete", SymPath ["StaticArray"] "delete"] ++ registerFunctionFunctionsWithInterface "delete")
551+
([SymPath ["Array"] "delete", SymPath ["StaticArray"] "delete", SymPath ["Box"] "delete"] ++ registerFunctionFunctionsWithInterface "delete")
528552
builtInSymbolInfo,
529553
interfaceBinder
530554
"copy"
531555
(FuncTy [RefTy (VarTy "a") (VarTy "q")] (VarTy "a") StaticLifetimeTy)
532-
([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy"] ++ registerFunctionFunctionsWithInterface "copy")
556+
([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy", SymPath ["Box"] "copy"] ++ registerFunctionFunctionsWithInterface "copy")
533557
builtInSymbolInfo,
534558
interfaceBinder
535559
"str"
536560
(FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
537-
(SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "str")
561+
(SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : SymPath ["Box"] "str" : registerFunctionFunctionsWithInterface "str")
538562
builtInSymbolInfo,
539563
interfaceBinder
540564
"prn"
541565
(FuncTy [VarTy "a"] StringTy StaticLifetimeTy)
542-
(SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
566+
(SymPath ["StaticArray"] "str" : SymPath ["Box"] "prn" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is)
543567
builtInSymbolInfo
544568
]
545569
builtInSymbolInfo = Info (-1) (-1) "Built-in." Set.empty (-1)

‎src/TypesToC.hs

+1
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ tyToCRawFunctionPtrFix FuncTy {} = "void*"
2626
tyToCRawFunctionPtrFix t = tyToCManglePtr False t
2727

2828
tyToCManglePtr :: Bool -> Ty -> String
29+
tyToCManglePtr b (StructTy (ConcreteNameTy (SymPath [] "Box")) [t]) = tyToCManglePtr b t ++ (if b then mangle "*" else "*")
2930
tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*")
3031
tyToCManglePtr b (RefTy r _) = tyToCManglePtr b r ++ (if b then mangle "*" else "*")
3132
tyToCManglePtr _ ty = f ty

‎test/box.carp

+24
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
(load "Test.carp")
2+
(use Test)
3+
4+
(Debug.sanitize-addresses)
5+
6+
(deftype Num [val Int])
7+
8+
(deftest test
9+
(assert-equal test
10+
&(Box.init @"foo")
11+
&(Box.init @"foo")
12+
"init works as expected")
13+
(assert-equal test
14+
2
15+
(Box.unbox (Box.init 2))
16+
"unbox works as expected")
17+
(assert-equal test
18+
1
19+
(let-do [box (Box.init (Num.init 0))]
20+
(Num.set-val! (Box.peek &box) 1)
21+
@(Num.val (Box.peek &box)))
22+
"peek works as expected"
23+
)
24+
)

0 commit comments

Comments
 (0)