Skip to content

Commit f35761f

Browse files
scolsenscolsen
committed
feat: initial box type, indirect recursion
This commit is bigger than it should be, for which I apologize, but it bundles a couple of changes that all work toward supporting recursive data types: - It makes type candidates their own module and additionally allows them to specify interface constraints -- that one or more member types must implement some set of interfaces. - Updates recursive type handling to allow for "indirect" recursion. This permits using types that implement two interfaces alloc and indirect as containers for the recursive part. - We now forward declare recursive types to support the case above. - Adds a (currently unsafe) Box type for supporting heap allocated, memory managed indirection.
1 parent 4af9259 commit f35761f

15 files changed

+591
-68
lines changed

‎CarpHask.cabal

Lines changed: 2 additions & 0 deletions
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,
@@ -61,6 +62,7 @@ library
6162
SymPath,
6263
Template,
6364
ToTemplate,
65+
TypeCandidate,
6466
TypeError,
6567
TypePredicates,
6668
Types,

‎src/BoxTemplates.hs

Lines changed: 277 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,277 @@
1+
-- | Module BoxTemplates defines Carp's Box type, a container for managed,
2+
-- heap allocated objects.
3+
module BoxTemplates
4+
(delete,
5+
nil,
6+
str,
7+
prn,
8+
BoxTemplates.init,
9+
getter,
10+
copy,
11+
unbox,
12+
)
13+
where
14+
15+
import Obj
16+
import Polymorphism
17+
import TypesToC
18+
import Concretize
19+
import Types
20+
import ToTemplate
21+
import Template
22+
23+
boxTy :: Ty
24+
boxTy = StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]
25+
26+
nil :: (String, Binder)
27+
nil = defineTypeParameterizedTemplate templateCreator path t docs
28+
where path = SymPath ["Box"] "nil"
29+
t = FuncTy [] boxTy StaticLifetimeTy
30+
docs = "Initializes a box pointing to nothing."
31+
templateCreator = TemplateCreator $
32+
\typeEnv env ->
33+
Template
34+
t
35+
(const (toTemplate "Box__$t $NAME ()"))
36+
(\(FuncTy _ _ _) ->
37+
toTemplate $
38+
unlines
39+
[ "$DECL {",
40+
" Box__$t box;",
41+
" box.data = NULL;",
42+
" return box;",
43+
"}"])
44+
45+
( \(FuncTy _ boxT _) ->
46+
depsForDeleteFunc typeEnv env boxT
47+
)
48+
init :: (String, Binder)
49+
init = defineTypeParameterizedTemplate templateCreator path t docs
50+
where path = SymPath ["Box"] "init"
51+
t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy
52+
docs = "Initializes a box pointing to value t."
53+
templateCreator = TemplateCreator $
54+
\_ _ ->
55+
Template
56+
t
57+
(templateLiteral "Box__$t $NAME ($t t)")
58+
(\_ ->
59+
multilineTemplate
60+
["$DECL {",
61+
" Box__$t instance;",
62+
" instance.data = CARP_MALLOC(sizeof($t));",
63+
" *instance.data = t;",
64+
" return instance;",
65+
"}"])
66+
(\_ -> [])
67+
68+
getter :: (String, Binder)
69+
getter = defineTypeParameterizedTemplate templateCreator path t docs
70+
where path = SymPath ["Box"] "deref"
71+
t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy
72+
docs = "Gets the value from a box and deletes the box."
73+
templateCreator = TemplateCreator $
74+
\_ _ ->
75+
Template
76+
t
77+
(templateLiteral "$t $NAME (Box__$t box)")
78+
(\_ ->
79+
multilineTemplate
80+
["$DECL {",
81+
" return *box.data;",
82+
"}"])
83+
(\_ -> [])
84+
85+
unbox :: (String, Binder)
86+
unbox = defineTypeParameterizedTemplate templateCreator path t docs
87+
where path = SymPath ["Box"] "unbox"
88+
t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy
89+
docs = "Convert a box to a ref and delete the box."
90+
templateCreator = TemplateCreator $
91+
\_ _ ->
92+
Template
93+
t
94+
(templateLiteral "$t* $NAME(Box__$t* box)")
95+
(\_ ->
96+
multilineTemplate
97+
[ "$DECL {",
98+
" return box->data;",
99+
"}"
100+
])
101+
(\_ -> [])
102+
103+
copy :: (String, Binder)
104+
copy = defineTypeParameterizedTemplate templateCreator path t docs
105+
where path = SymPath ["Box"] "copy"
106+
t = FuncTy[(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) StaticLifetimeTy
107+
docs = "copies a box."
108+
templateCreator = TemplateCreator $
109+
\tenv env ->
110+
Template
111+
t
112+
(templateLiteral "Box__$t $NAME (Box__$t* box)")
113+
(\(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) ->
114+
innerCopy tenv env inner)
115+
(\(FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) ->
116+
depsForCopyFunc tenv env inner
117+
++ depsForDeleteFunc tenv env boxType)
118+
innerCopy typeEnv valEnv innerTy =
119+
case findFunctionForMemberIncludePrimitives typeEnv valEnv "copy" (typesCopyFunctionType innerTy) ("Inside box.", innerTy) of
120+
FunctionFound functionFullName ->
121+
multilineTemplate
122+
[ "$DECL {",
123+
" Box__$t copy;",
124+
" copy.data = CARP_MALLOC(sizeof($t));",
125+
" if (box->data) {",
126+
" *copy.data = " ++ functionFullName ++ "(box->data);\n",
127+
" } else {",
128+
" copy.data = NULL;",
129+
" }",
130+
" return copy;",
131+
"}"
132+
]
133+
_ ->
134+
multilineTemplate
135+
[ "$DECL {",
136+
" Box__$t copy;",
137+
" copy.data = CARP_MALLOC(sizeof($t));",
138+
" if (box->data) { ",
139+
" *copy.data = *box->data;",
140+
" } else {",
141+
" copy.data = NULL;",
142+
" }",
143+
" return copy;",
144+
"}"
145+
]
146+
--FunctionIgnored ->
147+
-- [ "$DECL {",
148+
-- " Box__$t copy;",
149+
-- " copy.data = CARP_MALLOC(sizeof($t));",
150+
-- " *copy.data = box->data;",
151+
-- " return copy;"
152+
-- ]
153+
-- " /* Ignore type inside Array when copying: '" ++ show t ++ "' (no copy function known)*/\n"
154+
155+
prn :: (String, Binder)
156+
prn = defineTypeParameterizedTemplate templateCreator path t docs
157+
where path = SymPath ["Box"] "prn"
158+
t = FuncTy [boxTy] StringTy StaticLifetimeTy
159+
docs = "Returns a string representation of a Box."
160+
templateCreator = TemplateCreator $
161+
(\tenv env ->
162+
Template
163+
t
164+
(templateLiteral "String $NAME (Box__$t box)")
165+
(\(FuncTy [boxT] StringTy _) -> multilineTemplate
166+
["$DECL {",
167+
" if(!box.data){return \"Nil\";}",
168+
" String temp = NULL;",
169+
" int size = 6;",
170+
innerStr tenv env boxT,
171+
-- " bufferPtr += 1;",
172+
" sprintf(bufferPtr, \")\");",
173+
" return buffer;",
174+
"}"])
175+
(\(FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) ->
176+
depsForPrnFunc tenv env inner
177+
))
178+
179+
str :: (String, Binder)
180+
str = defineTypeParameterizedTemplate templateCreator path t docs
181+
where path = SymPath ["Box"] "str"
182+
t = FuncTy [(RefTy boxTy (VarTy "q"))] StringTy StaticLifetimeTy
183+
docs = "Returns a string representation of a Box."
184+
templateCreator = TemplateCreator $
185+
(\tenv env ->
186+
Template
187+
t
188+
(templateLiteral "String $NAME (Box__$t* box)")
189+
(\(FuncTy [RefTy boxT _] StringTy _) -> multilineTemplate
190+
["$DECL {",
191+
" if(!box->data){",
192+
" String buffer = CARP_MALLOC(4);",
193+
" sprintf(buffer, \"Nil\");",
194+
" return buffer;",
195+
" }",
196+
" String temp = NULL;",
197+
" int size = 12;",
198+
innerStr tenv env boxT,
199+
" bufferPtr += 1;",
200+
" sprintf(bufferPtr, \")\");",
201+
" return buffer;",
202+
"}"])
203+
(\(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) ->
204+
depsForPrnFunc tenv env inner
205+
))
206+
207+
innerStr :: TypeEnv -> Env -> Ty -> String
208+
innerStr tenv env (StructTy _ [t]) =
209+
case findFunctionForMemberIncludePrimitives tenv env "prn" (typesStrFunctionType tenv env (RefTy t StaticLifetimeTy)) ("Inside box.", t) of
210+
FunctionFound functionFullName ->
211+
unlines
212+
[ " temp = " ++ functionFullName ++ "(box->data);",
213+
" size += snprintf(NULL, 0, \"%s \", temp);",
214+
" String buffer = CARP_MALLOC(size);",
215+
" String bufferPtr = buffer;",
216+
" sprintf(bufferPtr, \"(Box \");",
217+
" bufferPtr += 1;",
218+
" sprintf(bufferPtr, \"%s \", temp);",
219+
" bufferPtr += strlen(temp) + 1;",
220+
" if(temp) {",
221+
" CARP_FREE(temp);",
222+
" temp = NULL;",
223+
" }"
224+
]
225+
FunctionNotFound _ ->
226+
unlines
227+
[ " temp = \"unknown\";",
228+
" size += snprintf(NULL, 0, \"%s \", temp);",
229+
" String buffer = CARP_MALLOC(size);",
230+
" String bufferPtr = buffer;",
231+
" sprintf(bufferPtr, \"(Box \");",
232+
" bufferPtr += 1;",
233+
" sprintf(bufferPtr, \"%s \", temp);",
234+
" bufferPtr += strlen(temp) + 1;",
235+
" if(temp) {",
236+
" CARP_FREE(temp);",
237+
" temp = NULL;",
238+
" }"
239+
]
240+
FunctionIgnored -> " /* Ignore type inside Box: '" ++ show t ++ "' ??? */\n"
241+
innerStr _ _ _ = ""
242+
243+
delete :: (String, Binder)
244+
delete = defineTypeParameterizedTemplate templateCreator path t docs
245+
where path = SymPath ["Box"] "delete"
246+
t = FuncTy [boxTy] UnitTy StaticLifetimeTy
247+
docs = "Deletes a box, freeing its associated memory."
248+
templateCreator = TemplateCreator $
249+
\tenv env ->
250+
Template
251+
t
252+
(const (toTemplate "void $NAME (Box__$t box)"))
253+
(\(FuncTy [bTy] UnitTy _) ->
254+
toTemplate $
255+
unlines [
256+
"$DECL {",
257+
innerDelete tenv env bTy,
258+
"}"])
259+
( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) ->
260+
depsForDeleteFunc tenv env insideType
261+
)
262+
263+
innerDelete :: TypeEnv -> Env -> Ty -> String
264+
innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) =
265+
case findFunctionForMember tenv env "delete" (typesDeleterFunctionType inner) ("Inside box.", inner) of
266+
FunctionFound functionFullName ->
267+
" if(box.data){\n" ++
268+
" " ++ functionFullName ++ "(((" ++ tyToCLambdaFix inner ++ "*)box.data));\n" ++
269+
" CARP_FREE(box.data);" ++
270+
" }\n"
271+
FunctionNotFound msg -> error msg
272+
FunctionIgnored ->
273+
" /* Ignore non-managed type inside Box: '" ++ show inner ++ "' */\n" ++
274+
" if(box.data){\n" ++
275+
" CARP_FREE(box.data);" ++
276+
" }\n"
277+
innerDelete _ _ _ = ""

‎src/Concretize.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ import qualified Set
4444
import SumtypeCase
4545
import ToTemplate
4646
import TypeError
47+
import TypeCandidate
4748
import TypePredicates
4849
import Types
4950
import TypesToC
@@ -612,7 +613,7 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic
612613
let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
613614
validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
614615
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
615-
candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig}
616+
candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env }
616617
validateMembers typeEnv env candidate
617618
deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
618619
let xobj =
@@ -647,7 +648,7 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
647648
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
648649
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
649650
deps = mapM (depsForCase typeEnv env) concretelyTypedCases
650-
candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases }
651+
candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env }
651652
in case toCases typeEnv env candidate of -- Don't care about the cases, this is done just for validation.
652653
Left err -> Left err
653654
Right _ ->

‎src/Deftype.hs

Lines changed: 12 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import Obj
1818
import StructUtils
1919
import Template
2020
import ToTemplate
21+
import TypeCandidate
2122
import TypeError
2223
import TypePredicates
2324
import Types
@@ -31,7 +32,7 @@ import Validate
3132
moduleForDeftypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
3233
moduleForDeftypeInContext ctx name vars members info =
3334
let global = contextGlobalEnv ctx
34-
types = contextTypeEnv ctx
35+
ts = contextTypeEnv ctx
3536
path = contextPath ctx
3637
inner = either (const Nothing) Just (innermostModuleEnv ctx)
3738
previous =
@@ -48,7 +49,7 @@ moduleForDeftypeInContext ctx name vars members info =
4849
_ -> Left "Non module"
4950
)
5051
)
51-
in moduleForDeftype inner types global path name vars members info previous
52+
in moduleForDeftype inner ts global path name vars members info previous
5253

5354
-- | This function creates a "Type Module" with the same name as the type being defined.
5455
-- A type module provides a namespace for all the functions that area automatically
@@ -60,23 +61,27 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
6061
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
6162
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
6263
insidePath = pathStrings ++ [typeName]
63-
candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = typeVariables, typemembers = []}
64+
candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = typeVariables, typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env}
6465
in do
6566
mems <- case rest of
6667
[XObj (Arr membersXObjs) _ _] -> Right membersXObjs
6768
_ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy))
68-
validateMembers typeEnv env (candidate {typemembers = mems})
6969
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
7070
ptrmembers = map (recursiveMembersToPointers structTy) rest
71+
innermems <- case ptrmembers of
72+
[XObj (Arr membersXObjs) _ _] -> Right membersXObjs
73+
_ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy))
74+
okRecursive (candidate {typemembers = mems})
75+
validateMembers typeEnv env (candidate {typemembers = innermems})
7176
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers
72-
okInit <- if (any (isRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy ptrmembers
77+
okInit <- if (any (isValueRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy ptrmembers
7378
okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers
7479
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers "str"
7580
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers"prn"
7681
(okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy ptrmembers
7782
(okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy ptrmembers
7883
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
79-
funcs' = if (any (isRecursive structTy) ptrmembers) then (okMake : funcs) else funcs
84+
funcs' = if (any (isValueRecursive structTy) ptrmembers) then (okMake : funcs) else funcs
8085
moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs'
8186
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
8287
deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
@@ -90,7 +95,7 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
9095
let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv)
9196
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
9297
insidePath = pathStrings ++ [typeName]
93-
candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = [], typemembers = []}
98+
candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = [], typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env}
9499
in do
95100
mems <- case rest of
96101
[XObj (Arr membersXObjs) _ _] -> Right membersXObjs

0 commit comments

Comments
 (0)