|
| 1 | +module RecType |
| 2 | + ( |
| 3 | + recursiveMembersToPointers, |
| 4 | + isRecursive, |
| 5 | + recursiveProductMakeBinder, |
| 6 | + ) |
| 7 | +where |
| 8 | + |
| 9 | +import Obj |
| 10 | +import Types |
| 11 | +import TypePredicates |
| 12 | +import TypeError |
| 13 | +import TypesToC |
| 14 | +import StructUtils |
| 15 | +import Template |
| 16 | +import Util |
| 17 | +import Data.Maybe (fromJust) |
| 18 | +import Concretize |
| 19 | +import ToTemplate |
| 20 | + |
| 21 | +isRecursive :: Ty -> XObj -> Bool |
| 22 | +isRecursive structTy@(StructTy _ _) (XObj (Arr members) _ _) = |
| 23 | + any go members |
| 24 | + where go :: XObj -> Bool |
| 25 | + go xobj = case xobjTy xobj of |
| 26 | + Just (RecTy rec) -> rec == structTy |
| 27 | + _ -> False |
| 28 | +isRecursive _ _ = False |
| 29 | + |
| 30 | +-- | Converts member xobjs in a type definition that refer to the type into pointers |
| 31 | +recursiveMembersToPointers :: Ty -> XObj -> XObj |
| 32 | +recursiveMembersToPointers rec (XObj (Arr members) ai at) = |
| 33 | + (XObj (Arr (map go members)) ai at) |
| 34 | + where go :: XObj -> XObj |
| 35 | + go x@(XObj (Sym spath _) i _) = if show spath == tyname |
| 36 | + then (XObj (Lst [XObj (Sym (SymPath [] "RecTy") Symbol) i (Just (RecTy rec)), x]) i (Just (RecTy rec))) |
| 37 | + else x |
| 38 | + go x = x |
| 39 | + tyname = getStructName rec |
| 40 | +recursiveMembersToPointers _ xobj = xobj |
| 41 | + |
| 42 | +-------------------------------------------------------------------------------- |
| 43 | +-- Recursive product types |
| 44 | + |
| 45 | +recursiveProductMakeBinder :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) |
| 46 | +recursiveProductMakeBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = |
| 47 | + Right $ |
| 48 | + instanceBinder |
| 49 | + (SymPath insidePath "make") |
| 50 | + (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy) |
| 51 | + (recursiveProductMake StackAlloc structTy membersXObjs) |
| 52 | + ("creates a `" ++ show structTy ++ "`.") |
| 53 | + where initArgListTypes :: [XObj] -> [Ty] |
| 54 | + initArgListTypes xobjs = |
| 55 | + map (fromJust . xobjToTy . snd) (remove (isRecType . fromJust . xobjToTy . snd) (pairwise xobjs)) |
| 56 | +recursiveProductMakeBinder _ _ _ = error "TODO" |
| 57 | + |
| 58 | +-- | The template for the 'make' and 'new' functions for a concrete deftype. |
| 59 | +recursiveProductMake :: AllocationMode -> Ty -> [XObj] -> Template |
| 60 | +recursiveProductMake allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = |
| 61 | + let pairs = memberXObjsToPairs membersXObjs |
| 62 | + unitless = remove (isRecType . snd) . remove (isUnit . snd) |
| 63 | + in Template |
| 64 | + (FuncTy (map snd (unitless pairs)) (VarTy "p") StaticLifetimeTy) |
| 65 | + ( \(FuncTy _ concreteStructTy _) -> |
| 66 | + let mappings = unifySignatures originalStructTy concreteStructTy |
| 67 | + correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs |
| 68 | + memberPairs = memberXObjsToPairs correctedMembers |
| 69 | + in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")") |
| 70 | + ) |
| 71 | + ( \(FuncTy _ concreteStructTy _) -> |
| 72 | + let mappings = unifySignatures originalStructTy concreteStructTy |
| 73 | + correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs |
| 74 | + in productMakeTokens allocationMode (show originalStructTy) correctedMembers |
| 75 | + ) |
| 76 | + (\FuncTy {} -> []) |
| 77 | + where memberArg :: (String, Ty) -> String |
| 78 | + memberArg (memberName, memberTy) = |
| 79 | + tyToCLambdaFix (templatizeTy memberTy) ++ " " ++ memberName |
| 80 | + templatizeTy :: Ty -> Ty |
| 81 | + templatizeTy (VarTy vt) = VarTy ("$" ++ vt) |
| 82 | + templatizeTy (FuncTy argTys retTy ltTy) = FuncTy (map templatizeTy argTys) (templatizeTy retTy) (templatizeTy ltTy) |
| 83 | + templatizeTy (StructTy name tys) = StructTy name (map templatizeTy tys) |
| 84 | + templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt) |
| 85 | + templatizeTy (PointerTy t) = PointerTy (templatizeTy t) |
| 86 | + templatizeTy t = t |
| 87 | +recursiveProductMake _ _ _ = error "concreteinit" |
| 88 | + |
| 89 | +productMakeTokens :: AllocationMode -> String -> [XObj] -> [Token] |
| 90 | +productMakeTokens allocationMode typeName membersXObjs = |
| 91 | + let pairs = (memberXObjsToPairs membersXObjs) |
| 92 | + in toTemplate $ |
| 93 | + unlines |
| 94 | + [ "$DECL {", |
| 95 | + case allocationMode of |
| 96 | + StackAlloc -> " $p instance;" |
| 97 | + HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", |
| 98 | + assignments pairs, |
| 99 | + " return instance;", |
| 100 | + "}" |
| 101 | + ] |
| 102 | + where |
| 103 | + assignments ps = go (remove (isUnit . snd) ps) |
| 104 | + where |
| 105 | + go [] = "" |
| 106 | + go xobjs = joinLines $ assign allocationMode <$> xobjs |
| 107 | + assign alloc (name, ty) = |
| 108 | + let accessor = case alloc of |
| 109 | + StackAlloc -> "." |
| 110 | + HeapAlloc -> "->" |
| 111 | + in if isRecType ty |
| 112 | + then " instance" ++ accessor ++ name ++ " = " ++ "NULL ;" |
| 113 | + else " instance" ++ accessor ++ name ++ " = " ++ name ++ ";" |
| 114 | + |
| 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 | + |
| 155 | + |
| 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" |
0 commit comments