Skip to content

Commit aa56369

Browse files
scolsenscolsen
committed
feat: manage recursive product type memory
This commit adds a number of alternative type getters/initers for recursive product types. These are primarily needed to hide the underlying pointer implementation from the user (otherwise, users need to deal with pointers explicitly). This permits one to write: ```clojure (deftype IntList [head Int tail IntList]) (IntList.tail &(IntList.init 2 (IntList.make 1))) ``` Instead of writing: ```clojure (IntList.tail (Pointer.to-ref &(IntList.init 2 (Pointer.to-value (IntList.make 1))))) ```
1 parent 2205f4f commit aa56369

File tree

6 files changed

+141
-77
lines changed

6 files changed

+141
-77
lines changed

‎src/Concretize.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -843,6 +843,8 @@ depsForCopyFunc typeEnv env t =
843843

844844
-- | Helper for finding the 'str' function for a type.
845845
depsForPrnFunc :: TypeEnv -> Env -> Ty -> [XObj]
846+
depsForPrnFunc typeEnv env (RecTy t) =
847+
depsOfPolymorphicFunction typeEnv env [] "str" (FuncTy [PointerTy t] StringTy StaticLifetimeTy)
846848
depsForPrnFunc typeEnv env t =
847849
if isManaged typeEnv env t
848850
then depsOfPolymorphicFunction typeEnv env [] "prn" (FuncTy [RefTy t (VarTy "q")] StringTy StaticLifetimeTy)
@@ -900,6 +902,8 @@ concreteDeleteTakePtr typeEnv env members =
900902
-- | Generate the C code for deleting a single member of the deftype.
901903
-- | TODO: Should return an Either since this can fail!
902904
memberDeletionGeneral :: String -> TypeEnv -> Env -> (String, Ty) -> String
905+
memberDeletionGeneral separator _ _ (memberName, (RecTy _)) =
906+
" " ++ "CARP_FREE(p" ++ separator ++ memberName ++ ");"
903907
memberDeletionGeneral separator typeEnv env (memberName, memberType) =
904908
case findFunctionForMember typeEnv env "delete" (typesDeleterFunctionType memberType) (memberName, memberType) of
905909
FunctionFound functionFullName -> " " ++ functionFullName ++ "(p" ++ separator ++ memberName ++ ");"

‎src/Debug.hs

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
module Debug where
2+
3+
import qualified Map
4+
import Obj
5+
import SymPath
6+
import Util
7+
8+
showEnvBinderValues :: Env -> String
9+
showEnvBinderValues =
10+
joinLines . (map (pretty . binderXObj . snd)) . Map.toList . envBindings
11+
12+
showContextGlobalValues :: Context -> String
13+
showContextGlobalValues =
14+
(++) "Context Global Bindings:\n" . showEnvBinderValues . contextGlobalEnv
15+
16+
showBinderInEnv :: Env -> SymPath -> String
17+
showBinderInEnv e spath =
18+
joinLines (map pretty (filter (\p -> (getPath p) == spath) (map (binderXObj . snd) (Map.toList (envBindings e)))))

‎src/Deftype.hs

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,7 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
6969
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
7070
ptrmembers = map (recursiveMembersToPointers structTy) rest
7171
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers
72-
okInit <- binderForInit insidePath structTy ptrmembers
72+
okInit <- if (any (isRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy ptrmembers
7373
okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers
7474
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers "str"
7575
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers"prn"
@@ -125,6 +125,12 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _
125125
(FuncTy [p, t] p StaticLifetimeTy)
126126
(FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
127127
(FuncTy [p, RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
128+
(RecTy t') ->
129+
binders
130+
(FuncTy [RefTy p (VarTy "q")] (RefTy t' (VarTy "q")) StaticLifetimeTy)
131+
(FuncTy [p, t] p StaticLifetimeTy)
132+
(FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
133+
(FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
128134
_ ->
129135
binders
130136
(FuncTy [RefTy p (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy)
@@ -152,6 +158,7 @@ templatesForSingleMember _ _ _ _ _ = error "templatesforsinglemember"
152158

153159
-- | The template for getters of a deftype.
154160
templateGetter :: String -> Ty -> Template
161+
templateGetter member t@(RecTy _) = recTemplateGetter member t
155162
templateGetter _ UnitTy =
156163
Template
157164
(FuncTy [RefTy (VarTy "p") (VarTy "q")] UnitTy StaticLifetimeTy)
@@ -347,7 +354,7 @@ templateUpdater member _ =
347354

348355
-- | Helper function to create the binder for the 'init' template.
349356
binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
350-
binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
357+
binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [(XObj (Arr membersXObjs) _ _)] =
351358
if isTypeGeneric structTy
352359
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
353360
else

‎src/Managed.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ import Types
77
-- | Should this type be handled by the memory management system.
88
-- Implementation note: This top-level pattern match should be able to just
99
-- match on all types and see whether they implement 'delete', but for some
10-
-- reson that doesn't work. Might need to handle generic types separately?
10+
-- reason that doesn't work. Might need to handle generic types separately?
1111
isManaged :: TypeEnv -> Env -> Ty -> Bool
1212
isManaged typeEnv globalEnv structTy@StructTy {} =
1313
interfaceImplementedForTy typeEnv globalEnv "delete" (FuncTy [structTy] UnitTy StaticLifetimeTy)
@@ -17,5 +17,7 @@ isManaged _ _ StringTy =
1717
True
1818
isManaged _ _ PatternTy =
1919
True
20+
isManaged _ _ (RecTy _) =
21+
True
2022
isManaged _ _ _ =
2123
False

‎src/RecType.hs

Lines changed: 93 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,8 @@ module RecType
33
recursiveMembersToPointers,
44
isRecursive,
55
recursiveProductMakeBinder,
6+
recursiveProductInitBinder,
7+
recTemplateGetter,
68
)
79
where
810

@@ -18,7 +20,7 @@ import Data.Maybe (fromJust)
1820
import Concretize
1921
import ToTemplate
2022

21-
isRecursive :: Ty -> XObj -> Bool
23+
isRecursive :: Ty -> XObj -> Bool
2224
isRecursive structTy@(StructTy _ _) (XObj (Arr members) _ _) =
2325
any go members
2426
where go :: XObj -> Bool
@@ -44,7 +46,7 @@ recursiveMembersToPointers _ xobj = xobj
4446

4547
recursiveProductMakeBinder :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
4648
recursiveProductMakeBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
47-
Right $
49+
Right $
4850
instanceBinder
4951
(SymPath insidePath "make")
5052
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
@@ -55,6 +57,84 @@ recursiveProductMakeBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [
5557
map (fromJust . xobjToTy . snd) (remove (isRecType . fromJust . xobjToTy . snd) (pairwise xobjs))
5658
recursiveProductMakeBinder _ _ _ = error "TODO"
5759

60+
recursiveProductInitBinder :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
61+
recursiveProductInitBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
62+
Right $
63+
instanceBinder
64+
(SymPath insidePath "init")
65+
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
66+
(recursiveProductInit HeapAlloc structTy membersXObjs)
67+
("creates a `" ++ show structTy ++ "`.")
68+
where initArgListTypes :: [XObj] -> [Ty]
69+
initArgListTypes xobjs =
70+
map (fixRec . fromJust . xobjToTy . snd) (pairwise xobjs)
71+
fixRec (RecTy t) = t
72+
fixRec t = t
73+
recursiveProductInitBinder _ _ _ = error "TODO"
74+
75+
-- | The template for the 'make' and 'new' functions for a concrete deftype.
76+
recursiveProductInit :: AllocationMode -> Ty -> [XObj] -> Template
77+
recursiveProductInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
78+
let pairs = memberXObjsToPairs membersXObjs
79+
unitless = remove (isUnit . snd)
80+
unrec = map go . unitless
81+
go (x, (RecTy t)) = (x, t)
82+
go (x, t) = (x, t)
83+
in Template
84+
(FuncTy (map snd (unrec pairs)) (VarTy "p") StaticLifetimeTy)
85+
( \(FuncTy _ concreteStructTy _) ->
86+
let mappings = unifySignatures originalStructTy concreteStructTy
87+
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
88+
memberPairs = memberXObjsToPairs correctedMembers
89+
in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unrec memberPairs)) ++ ")")
90+
)
91+
( \(FuncTy _ concreteStructTy _) ->
92+
let mappings = unifySignatures originalStructTy concreteStructTy
93+
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
94+
in productInitTokens allocationMode (show originalStructTy) correctedMembers
95+
)
96+
(\FuncTy {} -> [])
97+
where memberArg :: (String, Ty) -> String
98+
memberArg (memberName, memberTy) =
99+
tyToCLambdaFix (templatizeTy memberTy) ++ " " ++ memberName
100+
templatizeTy :: Ty -> Ty
101+
templatizeTy (VarTy vt) = VarTy ("$" ++ vt)
102+
templatizeTy (FuncTy argTys retTy ltTy) = FuncTy (map templatizeTy argTys) (templatizeTy retTy) (templatizeTy ltTy)
103+
templatizeTy (StructTy name tys) = StructTy name (map templatizeTy tys)
104+
templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt)
105+
templatizeTy (PointerTy t) = PointerTy (templatizeTy t)
106+
templatizeTy t = t
107+
recursiveProductInit _ _ _ = error "concreteinit"
108+
109+
productInitTokens :: AllocationMode -> String -> [XObj] -> [Token]
110+
productInitTokens allocationMode typeName membersXObjs =
111+
let pairs = (memberXObjsToPairs membersXObjs)
112+
in toTemplate $
113+
unlines
114+
[ "$DECL {",
115+
case allocationMode of
116+
StackAlloc -> " $p instance;"
117+
HeapAlloc -> " $p *instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
118+
assignments pairs,
119+
" return *instance;",
120+
"}"
121+
]
122+
where
123+
assignments ps = go (remove (isUnit . snd) ps)
124+
where
125+
go [] = ""
126+
go xobjs = joinLines $ assign allocationMode <$> xobjs
127+
assign _ (name, (RecTy _)) =
128+
" instance" ++ "->" ++ name ++ " = " ++ "CARP_MALLOC(sizeof(" ++ typeName ++ "));\n"
129+
++ " *instance->" ++ name ++ " = " ++ name ++ ";\n"
130+
-- ++ " instance" ++ "->" ++ name ++ " = " ++ "&" ++ name ++ ";\n"
131+
-- ++ " " ++ typeName ++"_delete(" ++ name ++ ");"
132+
assign alloc (name, _) =
133+
let accessor = case alloc of
134+
StackAlloc -> "."
135+
HeapAlloc -> "->"
136+
in " instance" ++ accessor ++ name ++ " = " ++ name ++ ";"
137+
58138
-- | The template for the 'make' and 'new' functions for a concrete deftype.
59139
recursiveProductMake :: AllocationMode -> Ty -> [XObj] -> Template
60140
recursiveProductMake allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
@@ -104,82 +184,21 @@ productMakeTokens allocationMode typeName membersXObjs =
104184
where
105185
go [] = ""
106186
go xobjs = joinLines $ assign allocationMode <$> xobjs
107-
assign alloc (name, ty) =
187+
assign alloc (name, ty) =
108188
let accessor = case alloc of
109189
StackAlloc -> "."
110190
HeapAlloc -> "->"
111-
in if isRecType ty
191+
in if isRecType ty
112192
then " instance" ++ accessor ++ name ++ " = " ++ "NULL ;"
113193
else " instance" ++ accessor ++ name ++ " = " ++ name ++ ";"
114194

115-
---- | Generate a list of types from a deftype declaration.
116-
--initArgListTypes :: [XObj] -> [Ty]
117-
--initArgListTypes xobjs =
118-
-- map (fromJust . xobjToTy . snd) (pairwise xobjs)
119-
120-
--tokensForRecInit :: AllocationMode -> String -> [XObj] -> [Token]
121-
--tokensForRecInit allocationMode typeName membersXObjs =
122-
-- toTemplate $
123-
-- unlines
124-
-- [ "$DECL {",
125-
-- case allocationMode of
126-
-- StackAlloc -> case unitless of
127-
-- -- if this is truly a memberless struct, init it to 0;
128-
-- -- This can happen, e.g. in cases where *all* members of the struct are of type Unit.
129-
-- -- Since we do not generate members for Unit types.
130-
-- [] -> " $p instance = {};"
131-
-- _ -> " $p instance;"
132-
-- HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
133-
-- assignments membersXObjs,
134-
-- recAssignment recmembers,
135-
-- " return instance;",
136-
-- "}"
137-
-- ]
138-
-- where
139-
-- recmembers = filter (isRecType . snd) (memberXObjsToPairs membersXObjs)
140-
-- assignments [] = " instance.__dummy = 0;"
141-
-- assignments _ = go unitless
142-
-- where
143-
-- go [] = ""
144-
-- go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs
145-
-- unitless = remove isRecType (remove (isUnit . snd) (memberXObjsToPairs membersXObjs))
146-
-- recAssignment xs =
147-
--
148-
--memberAssignment :: AllocationMode -> String -> String
149-
--memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
150-
-- where
151-
-- sep = case allocationMode of
152-
-- StackAlloc -> "."
153-
-- HeapAlloc -> "->"
154-
195+
-- | The template for getters of recursive types.
196+
recTemplateGetter :: String -> Ty -> Template
197+
recTemplateGetter member (RecTy t) =
198+
Template
199+
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy)
200+
(const (toTemplate ((tyToC (PointerTy t)) ++ " $NAME($(Ref p) p)")))
201+
(const $ toTemplate ("$DECL { return p->" ++ member ++"; }\n"))
202+
(const [])
203+
recTemplateGetter _ _ = error "rectemplate getter"
155204

156-
--
157-
---- | The template for the 'init' and 'new' functions for a generic deftype.
158-
--genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
159-
--genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
160-
-- defineTypeParameterizedTemplate templateCreator path t docs
161-
-- where
162-
-- path = SymPath pathStrings "init"
163-
-- t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
164-
-- docs = "creates a `" ++ show originalStructTy ++ "`."
165-
-- templateCreator = TemplateCreator $
166-
-- \typeEnv env ->
167-
-- Template
168-
-- (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
169-
-- ( \(FuncTy _ concreteStructTy _) ->
170-
-- let mappings = unifySignatures originalStructTy concreteStructTy
171-
-- correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
172-
-- memberPairs = memberXObjsToPairs correctedMembers
173-
-- in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")")
174-
-- )
175-
-- ( \(FuncTy _ concreteStructTy _) ->
176-
-- let mappings = unifySignatures originalStructTy concreteStructTy
177-
-- correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
178-
-- in tokensForInit allocationMode (show originalStructTy) correctedMembers
179-
-- )
180-
-- ( \(FuncTy _ concreteStructTy _) ->
181-
-- case concretizeType typeEnv env concreteStructTy of
182-
-- Left _ -> []
183-
-- Right ok -> ok
184-
-- )
185-
--genericInit _ _ _ _ = error "genericinit"

‎src/StructUtils.hs

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@ import Interfaces
44
import Obj
55
import Polymorphism
66
import Types
7+
import TypesToC
78

89
data AllocationMode = StackAlloc | HeapAlloc
910

@@ -28,6 +29,13 @@ memberStrCallingConvention strOrPrn typeEnv globalEnv memberTy =
2829

2930
-- | Generate C code for converting a member variable to a string and appending it to a buffer.
3031
memberPrn :: TypeEnv -> Env -> (String, Ty) -> String
32+
memberPrn _ _ (_, (RecTy t)) =
33+
unlines
34+
[ " temp = \"" ++ tyToC t ++ "\";",
35+
" sprintf(bufferPtr, \"%s \", temp);",
36+
" bufferPtr += strlen(temp) + 1;",
37+
" if(temp) { CARP_FREE(temp); temp = NULL; }"
38+
]
3139
memberPrn typeEnv env (memberName, memberTy) =
3240
let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy
3341
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of
@@ -52,6 +60,12 @@ memberPrn typeEnv env (memberName, memberTy) =
5260

5361
-- | Calculate the size for prn:ing a member of a struct
5462
memberPrnSize :: TypeEnv -> Env -> (String, Ty) -> String
63+
memberPrnSize _ _ (_, (RecTy t)) =
64+
unlines
65+
[ " temp = \"" ++ tyToC t ++ "\";",
66+
" size += snprintf(NULL, 0, \"%s \", temp);",
67+
" if(temp) { CARP_FREE(temp); temp = NULL; }"
68+
]
5569
memberPrnSize typeEnv env (memberName, memberTy) =
5670
let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy
5771
in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of

0 commit comments

Comments
 (0)