From df3947733ffc37ac75768500ac7b62a6a5caeeb9 Mon Sep 17 00:00:00 2001 From: scottolsen Date: Wed, 13 Oct 2021 13:04:28 -0400 Subject: [PATCH 01/13] refactor: add a data type for type validation This makes it easier to work with validation functions at call sites as well as paves the way for permitting recursive types (we pass along the type name to validation procedures). --- src/Concretize.hs | 6 ++- src/Deftype.hs | 13 ++++- src/SumtypeCase.hs | 18 +++---- src/Sumtypes.hs | 5 +- src/Validate.hs | 125 ++++++++++++++++++++++++++------------------- 5 files changed, 99 insertions(+), 68 deletions(-) diff --git a/src/Concretize.hs b/src/Concretize.hs index 7b4a5462d..56baadcd0 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -612,7 +612,8 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs - validateMembers AllowAnyTypeVariableNames typeEnv env renamedOrig validMembers + candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig} + validateMembers typeEnv env candidate deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers) let xobj = XObj @@ -646,7 +647,8 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases deps = mapM (depsForCase typeEnv env) concretelyTypedCases - in case toCases typeEnv env AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation. + candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases } + in case toCases typeEnv env candidate of -- Don't care about the cases, this is done just for validation. Left err -> Left err Right _ -> case deps of diff --git a/src/Deftype.hs b/src/Deftype.hs index c4dbc87d6..c24803e42 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -59,8 +59,13 @@ 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] + candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = typeVariables, typemembers = []} in do - validateMemberCases typeEnv env typeVariables rest + mems <- case rest of + [XObj (Arr membersXObjs) _ _] -> Right membersXObjs + _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) + validateMembers typeEnv env (candidate {typemembers = mems}) + --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 @@ -82,8 +87,12 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) insidePath = pathStrings ++ [typeName] + candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = [], typemembers = []} in do - validateMemberCases typeEnv env [] rest + mems <- case rest of + [XObj (Arr membersXObjs) _ _] -> Right membersXObjs + _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) + validateMembers typeEnv env (candidate {typemembers = mems}) let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) [] (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest okInit <- binderForInit insidePath structTy rest diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs index 43cf45c88..2a12721ac 100644 --- a/src/SumtypeCase.hs +++ b/src/SumtypeCase.hs @@ -11,31 +11,31 @@ data SumtypeCase = SumtypeCase } deriving (Show, Eq) -toCases :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase] -toCases typeEnv globalEnv restriction typeVars = mapM (toCase typeEnv globalEnv restriction typeVars) +toCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError [SumtypeCase] +toCases typeEnv globalEnv candidate = mapM (toCase (typename candidate) typeEnv globalEnv (restriction candidate) (variables candidate)) (typemembers candidate) -toCase :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase -toCase typeEnv globalEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = +toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase +toCase tyname typeEnv globalEnv varrestriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] pname) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = let tys = map xobjToTy tyXObjs in case sequence tys of Nothing -> Left (InvalidSumtypeCase x) Just okTys -> - let validated = map (\t -> canBeUsedAsMemberType restriction typeEnv globalEnv typeVars t x) okTys + let validated = map (\t -> canBeUsedAsMemberType tyname varrestriction typeEnv globalEnv typeVars t x) okTys in case sequence validated of Left e -> Left e Right _ -> Right $ SumtypeCase - { caseName = name, + { caseName = pname, caseTys = okTys } -toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) = +toCase _ _ _ _ _ (XObj (Sym (SymPath [] pname) Symbol) _ _) = Right $ SumtypeCase - { caseName = name, + { caseName = pname, caseTys = [] } -toCase _ _ _ _ x = +toCase _ _ _ _ _ x = Left (InvalidSumtypeCase x) diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 113b00970..58757fb8d 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -17,7 +17,7 @@ import TypePredicates import Types import TypesToC import Util -import Validate (TypeVarRestriction (..)) +import Validate (TypeVarRestriction (..), TypeCandidate (..)) getCase :: [SumtypeCase] -> String -> Maybe SumtypeCase getCase cases caseNameToFind = @@ -52,9 +52,10 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) insidePath = pathStrings ++ [typeName] + candidate = TypeCandidate {typename = typeName, variables = typeVariables, restriction = AllowOnlyNamesInScope, typemembers = rest} in do let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables - cases <- toCases typeEnv env AllowOnlyNamesInScope typeVariables rest + cases <- toCases typeEnv env candidate okIniters <- initers insidePath structTy cases okTag <- binderForTag insidePath structTy (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str" diff --git a/src/Validate.hs b/src/Validate.hs index 7b810a8ad..327f37b51 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -18,60 +18,79 @@ data TypeVarRestriction | AllowOnlyNamesInScope -- Used when checking a type definition, e.g. (deftype (Foo a) [x a]), requires a to be in scope deriving (Eq) +-- | TypeCandidate represents a type that's possibly valid or invalid. +data TypeCandidate = TypeCandidate { + -- the name of the type + typename :: String, + -- a list of all variables in the type head + variables :: [Ty], + -- all members of the type + typemembers :: [XObj], + -- what sort of type variables are permitted. + restriction :: TypeVarRestriction +} + -- | Make sure that the member declarations in a type definition -- | Follow the pattern [ , , ...] -- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies. -validateMemberCases :: TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError () -validateMemberCases typeEnv globalEnv typeVariables rest = mapM_ visit rest +validateMemberCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () +validateMemberCases typeEnv globalEnv candidate = --mapM_ visit (members candidate) + validateMembers typeEnv globalEnv (candidate {restriction = AllowOnlyNamesInScope}) + -- where + -- visit (XObj (Arr membersXObjs) _ _) = + -- validateMembers typeEnv globalEnv (candidate {restriction = AllowOnlyNamesInScope}) + -- visit xobj = + -- Left (InvalidSumtypeCase xobj) + +validateMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () +validateMembers typeEnv globalEnv candidate = + (checkUnevenMembers candidate) >> + (checkDuplicateMembers candidate) >> + (checkMembers typeEnv globalEnv candidate) >> + (checkKindConsistency candidate) + +-- | Returns an error if a type has an uneven number of members. +checkUnevenMembers :: TypeCandidate -> Either TypeError () +checkUnevenMembers candidate = + if even (length (typemembers candidate)) + then Right () + else Left (UnevenMembers (typemembers candidate)) + +-- | Returns an error if a type has more than one member with the same name. +checkDuplicateMembers :: TypeCandidate -> Either TypeError () +checkDuplicateMembers candidate = + if length fields == length uniqueFields + then Right () + else Left (DuplicatedMembers dups) where - visit (XObj (Arr membersXObjs) _ _) = - validateMembers AllowOnlyNamesInScope typeEnv globalEnv typeVariables membersXObjs - visit xobj = - Left (InvalidSumtypeCase xobj) + fields = fst <$> (pairwise (typemembers candidate)) + uniqueFields = nubBy ((==) `on` xobjObj) fields + dups = fields \\ uniqueFields -validateMembers :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError () -validateMembers typeVarRestriction typeEnv globalEnv typeVariables membersXObjs = - checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency +-- | Returns an error if the type variables in the body of the type and variables in the head of the type are of incompatible kinds. +checkKindConsistency :: TypeCandidate -> Either TypeError () +checkKindConsistency candidate = + case areKindsConsistent varsOnly of + Left var -> Left (InconsistentKinds var (typemembers candidate)) + _ -> pure () where - pairs = pairwise membersXObjs - -- Are the number of members even? - checkUnevenMembers :: Either TypeError () - checkUnevenMembers = - if even (length membersXObjs) - then Right () - else Left (UnevenMembers membersXObjs) - -- Are any members duplicated? - checkDuplicateMembers :: Either TypeError () - checkDuplicateMembers = - if length fields == length uniqueFields - then Right () - else Left (DuplicatedMembers dups) - where - fields = fst <$> pairs - uniqueFields = nubBy ((==) `on` xobjObj) fields - dups = fields \\ uniqueFields - -- Do all type variables have consistent kinds? - checkKindConsistency :: Either TypeError () - checkKindConsistency = - case areKindsConsistent varsOnly of - Left var -> Left (InconsistentKinds var membersXObjs) - _ -> pure () - where - -- fromJust is safe here; invalid types will be caught in the prior check. - -- todo? be safer anyway? - varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) pairs) - checkMembers :: Either TypeError () - checkMembers = mapM_ (okXObjForType typeVarRestriction typeEnv globalEnv typeVariables . snd) pairs + -- fromJust is safe here; invalid types will be caught in a prior check. + -- TODO: be safer. + varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) (pairwise (typemembers candidate))) + +-- | Returns an error if one of the types members can't be used as a member. +checkMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () +checkMembers typeEnv globalEnv candidate = mapM_ (okXObjForType (typename candidate) (restriction candidate) typeEnv globalEnv (variables candidate) . snd) (pairwise (typemembers candidate)) -okXObjForType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError () -okXObjForType typeVarRestriction typeEnv globalEnv typeVariables xobj = +okXObjForType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError () +okXObjForType tyname typeVarRestriction typeEnv globalEnv typeVariables xobj = case xobjToTy xobj of - Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables t xobj + Just t -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables t xobj Nothing -> Left (NotAType xobj) -- | Can this type be used as a member for a deftype? -canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError () -canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj = +canBeUsedAsMemberType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError () +canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables ty xobj = case ty of UnitTy -> pure () IntTy -> pure () @@ -86,7 +105,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj FuncTy {} -> pure () PointerTy UnitTy -> pure () PointerTy inner -> - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables inner xobj + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner xobj >> pure () -- Struct variables may appear as complete applications or individual -- components in the head of a definition; that is the forms: @@ -105,23 +124,23 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj -- ((Foo (f a) (f b)) ...) -- differ. -- Attempt the first, more restrictive formulation first. - struct@(StructTy name tyVars) -> - checkVar struct <> checkStruct name tyVars + struct@(StructTy sname tyVars) -> + checkVar struct <> checkStruct sname tyVars v@(VarTy _) -> checkVar v _ -> Left (InvalidMemberType ty xobj) where checkStruct :: Ty -> [Ty] -> Either TypeError () checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] = - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables innerType xobj + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj >> pure () - checkStruct (ConcreteNameTy path@(SymPath _ name)) vars = - case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of + checkStruct (ConcreteNameTy path@(SymPath _ pname)) vars = + case E.getTypeBinder typeEnv pname <> E.findTypeBinder globalEnv path of Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> pure () Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars _ -> Left (NotAmongRegisteredTypes ty xobj) where checkInhabitants :: Ty -> Either TypeError () @@ -131,8 +150,8 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj else Left (UninhabitedConstructor ty xobj (length vs) (length vars)) checkInhabitants _ = Left (InvalidMemberType ty xobj) checkStruct v@(VarTy _) vars = - canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables v xobj - >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables v xobj + >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars checkStruct _ _ = error "checkstruct" checkVar :: Ty -> Either TypeError () checkVar variable = From 2205f4f7ff7ab5e04c356b3e60fc90593ad1b888 Mon Sep 17 00:00:00 2001 From: scottolsen Date: Wed, 13 Oct 2021 17:40:37 -0400 Subject: [PATCH 02/13] feat: initial support for recursive product types This commit implements initial support for recursive product data types. In C, they're represented as structs that have a field that is a pointer to the same struct type. In Carp, we currently substitute recursive references with pointers to the type, and users must provide a pointer argument during instantiation. To make creating initial values of these types easier, we define a make function, which initializes a value of the type with its recursive part set to the null pointer. --- CarpHask.cabal | 1 + src/Constraints.hs | 8 ++ src/Deftype.hs | 19 +++-- src/Emit.hs | 26 ++++-- src/Obj.hs | 6 ++ src/Primitives.hs | 1 + src/RecType.hs | 185 ++++++++++++++++++++++++++++++++++++++++++ src/Scoring.hs | 1 + src/TypePredicates.hs | 4 + src/Types.hs | 9 ++ src/TypesToC.hs | 2 + src/Validate.hs | 22 +++-- 12 files changed, 260 insertions(+), 24 deletions(-) create mode 100644 src/RecType.hs diff --git a/CarpHask.cabal b/CarpHask.cabal index 8f1a6fe67..df1a1ec86 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -47,6 +47,7 @@ library PrimitiveError Project, Qualify, + RecType, Reify, RenderDocs, Repl, diff --git a/src/Constraints.hs b/src/Constraints.hs index a56ea57de..6d1e89baf 100644 --- a/src/Constraints.hs +++ b/src/Constraints.hs @@ -149,6 +149,13 @@ solveOneInternal mappings constraint = Right ok -> solveOneInternal ok (Constraint ltA ltB i1 i2 ctx ord) Left err -> Left err else Left (UnificationFailure constraint mappings) + -- Rec types + Constraint (PointerTy a) (RecTy b) _ _ _ _ -> + let (Constraint _ _ i1 i2 ctx ord) = constraint + in solveOneInternal mappings (Constraint a b i1 i2 ctx ord) + Constraint (RecTy a) (PointerTy b) _ _ _ _ -> + let (Constraint _ _ i1 i2 ctx ord) = constraint + in solveOneInternal mappings (Constraint a b i1 i2 ctx ord) -- Pointer types Constraint (PointerTy a) (PointerTy b) _ _ _ _ -> let (Constraint _ _ i1 i2 ctx ord) = constraint @@ -231,6 +238,7 @@ checkConflictInternal mappings constraint name otherTy = case otherTy of PointerTy otherInnerTy -> solveOneInternal mappings (mkConstraint OrdPtr xobj1 xobj2 ctx innerTy otherInnerTy) VarTy _ -> Right mappings + RecTy otherInnerTy -> solveOneInternal mappings (mkConstraint OrdPtr xobj1 xobj2 ctx innerTy otherInnerTy) _ -> Left (UnificationFailure constraint mappings) Just (RefTy innerTy lifetimeTy) -> case otherTy of diff --git a/src/Deftype.hs b/src/Deftype.hs index c24803e42..ad8cf2064 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -21,6 +21,7 @@ import ToTemplate import TypeError import TypePredicates import Types +import RecType import TypesToC import Util import Validate @@ -65,16 +66,18 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i [XObj (Arr membersXObjs) _ _] -> Right membersXObjs _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) validateMembers typeEnv env (candidate {typemembers = mems}) - --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 - (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 - (okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest + ptrmembers = map (recursiveMembersToPointers structTy) rest + (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers + okInit <- binderForInit insidePath structTy ptrmembers + okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers + (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers "str" + (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers"prn" + (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy ptrmembers + (okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy ptrmembers let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers - moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs + funcs' = if (any (isRecursive structTy) ptrmembers) then (okMake : funcs) else funcs + moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs' typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps pure (typeName, typeModuleXObj, deps) diff --git a/src/Emit.hs b/src/Emit.hs index e003e15aa..63f3f76df 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -24,6 +24,7 @@ import qualified Meta import Obj import Path (takeFileName) import Project +import RecType import Scoring import qualified Set import Template @@ -814,11 +815,16 @@ templateToDeclaration template path actualTy = term = if "#define" `isPrefixOf` stokens then "\n" else ";\n" in stokens ++ term -memberToDecl :: Int -> (XObj, XObj) -> State EmitterState () -memberToDecl indent (memberName, memberType) = +memberToDecl :: Ty -> Int -> (XObj, XObj) -> State EmitterState () +memberToDecl recty indent (memberName, memberType) = case xobjToTy memberType of -- Handle function pointers as members specially to allow members that are functions referring to the struct itself. - Just t -> appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ mangle (getName memberName) ++ ";\n") + Just rt@(RecTy t) -> + if t == recty + then appendToSrc (addIndent indent ++ "struct " ++ tyToCLambdaFix rt ++ " " ++ mangle (getName memberName) ++ ";\n") + else appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ mangle (getName memberName) ++ ";\n") + Just t -> + appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ mangle (getName memberName) ++ ";\n") Nothing -> error ("Invalid memberType: " ++ show memberType) defStructToDeclaration :: Ty -> SymPath -> [XObj] -> String @@ -827,12 +833,18 @@ defStructToDeclaration structTy@(StructTy _ _) _ rest = typedefCaseToMemberDecl :: XObj -> State EmitterState [()] -- ANSI C doesn't allow empty structs, insert a dummy member to keep the compiler happy. typedefCaseToMemberDecl (XObj (Arr []) _ _) = sequence $ pure $ appendToSrc (addIndent indent ++ "char __dummy;\n") - typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl indent) (remove (isUnit . fromJust . xobjToTy . snd) (pairwise members)) + typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl structTy indent) (remove (isUnit . fromJust . xobjToTy . snd) (pairwise members)) typedefCaseToMemberDecl _ = error "Invalid case in typedef." + pointerfix = map (recursiveMembersToPointers structTy) rest -- Note: the names of types are not namespaced visit = do - appendToSrc "typedef struct {\n" - mapM_ typedefCaseToMemberDecl rest + -- forward declaration for recursive types. + when (any (isRecursive structTy) pointerfix) $ + do appendToSrc ("// Recursive type \n") + appendToSrc ("typedef struct " ++ tyToC structTy ++ " {\n") + when (all (not . isRecursive structTy) pointerfix) $ appendToSrc "typedef struct {\n" + --appendToSrc ("typedef struct " ++ tyToC structTy ++ " " ++ tyToC structTy ++ ";\n") + mapM_ typedefCaseToMemberDecl pointerfix appendToSrc ("} " ++ tyToC structTy ++ ";\n") in if isTypeGeneric structTy then "" -- ("// " ++ show structTy ++ "\n") @@ -859,7 +871,7 @@ defSumtypeToDeclaration sumTy@(StructTy _ _) rest = do appendToSrc (addIndent ind ++ "struct {\n") let members = zip anonMemberSymbols (remove (isUnit . fromJust . xobjToTy) memberTys) - mapM_ (memberToDecl (ind + indentAmount)) members + mapM_ (memberToDecl sumTy (ind + indentAmount)) members appendToSrc (addIndent ind ++ "} " ++ caseName ++ ";\n") emitSumtypeCase ind (XObj (Sym (SymPath [] caseName) _) _ _) = appendToSrc (addIndent ind ++ "// " ++ caseName ++ "\n") diff --git a/src/Obj.hs b/src/Obj.hs index 02f5d9084..7f2d3d650 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -823,6 +823,12 @@ xobjToTy (XObj (Sym (SymPath _ "Static") _) _ _) = Just StaticLifetimeTy xobjToTy (XObj (Sym spath@(SymPath _ s@(firstLetter : _)) _) _ _) | isLower firstLetter = Just (VarTy s) | otherwise = Just (StructTy (ConcreteNameTy spath) []) +xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "RecTy") _) _ _, innerTy]) _ _) = + do + okInnerTy <- xobjToTy innerTy + pure (RecTy okInnerTy) +xobjToTy (XObj (Lst (XObj (Sym (SymPath _ "RecTy") _) _ _ : _)) _ _) = + Nothing xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) = do okInnerTy <- xobjToTy innerTy diff --git a/src/Primitives.hs b/src/Primitives.hs index 4e9149847..0f9b41254 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -27,6 +27,7 @@ import Obj import PrimitiveError import Project import Qualify (Qualified (..), QualifiedPath, getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify) +--import RecType import Reify import Sumtypes import SymPath diff --git a/src/RecType.hs b/src/RecType.hs new file mode 100644 index 000000000..8ca6dfcf4 --- /dev/null +++ b/src/RecType.hs @@ -0,0 +1,185 @@ +module RecType + ( + recursiveMembersToPointers, + isRecursive, + recursiveProductMakeBinder, + ) +where + +import Obj +import Types +import TypePredicates +import TypeError +import TypesToC +import StructUtils +import Template +import Util +import Data.Maybe (fromJust) +import Concretize +import ToTemplate + +isRecursive :: Ty -> XObj -> Bool +isRecursive structTy@(StructTy _ _) (XObj (Arr members) _ _) = + any go members + where go :: XObj -> Bool + go xobj = case xobjTy xobj of + Just (RecTy rec) -> rec == structTy + _ -> False +isRecursive _ _ = False + +-- | Converts member xobjs in a type definition that refer to the type into pointers +recursiveMembersToPointers :: Ty -> XObj -> XObj +recursiveMembersToPointers rec (XObj (Arr members) ai at) = + (XObj (Arr (map go members)) ai at) + where go :: XObj -> XObj + go x@(XObj (Sym spath _) i _) = if show spath == tyname + then (XObj (Lst [XObj (Sym (SymPath [] "RecTy") Symbol) i (Just (RecTy rec)), x]) i (Just (RecTy rec))) + else x + go x = x + tyname = getStructName rec +recursiveMembersToPointers _ xobj = xobj + +-------------------------------------------------------------------------------- +-- Recursive product types + +recursiveProductMakeBinder :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) +recursiveProductMakeBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = + Right $ + instanceBinder + (SymPath insidePath "make") + (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy) + (recursiveProductMake StackAlloc structTy membersXObjs) + ("creates a `" ++ show structTy ++ "`.") + where initArgListTypes :: [XObj] -> [Ty] + initArgListTypes xobjs = + map (fromJust . xobjToTy . snd) (remove (isRecType . fromJust . xobjToTy . snd) (pairwise xobjs)) +recursiveProductMakeBinder _ _ _ = error "TODO" + +-- | The template for the 'make' and 'new' functions for a concrete deftype. +recursiveProductMake :: AllocationMode -> Ty -> [XObj] -> Template +recursiveProductMake allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = + let pairs = memberXObjsToPairs membersXObjs + unitless = remove (isRecType . snd) . remove (isUnit . snd) + in Template + (FuncTy (map snd (unitless pairs)) (VarTy "p") StaticLifetimeTy) + ( \(FuncTy _ concreteStructTy _) -> + let mappings = unifySignatures originalStructTy concreteStructTy + correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs + memberPairs = memberXObjsToPairs correctedMembers + in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")") + ) + ( \(FuncTy _ concreteStructTy _) -> + let mappings = unifySignatures originalStructTy concreteStructTy + correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs + in productMakeTokens allocationMode (show originalStructTy) correctedMembers + ) + (\FuncTy {} -> []) + where memberArg :: (String, Ty) -> String + memberArg (memberName, memberTy) = + tyToCLambdaFix (templatizeTy memberTy) ++ " " ++ memberName + templatizeTy :: Ty -> Ty + templatizeTy (VarTy vt) = VarTy ("$" ++ vt) + templatizeTy (FuncTy argTys retTy ltTy) = FuncTy (map templatizeTy argTys) (templatizeTy retTy) (templatizeTy ltTy) + templatizeTy (StructTy name tys) = StructTy name (map templatizeTy tys) + templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt) + templatizeTy (PointerTy t) = PointerTy (templatizeTy t) + templatizeTy t = t +recursiveProductMake _ _ _ = error "concreteinit" + +productMakeTokens :: AllocationMode -> String -> [XObj] -> [Token] +productMakeTokens allocationMode typeName membersXObjs = + let pairs = (memberXObjsToPairs membersXObjs) + in toTemplate $ + unlines + [ "$DECL {", + case allocationMode of + StackAlloc -> " $p instance;" + HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", + assignments pairs, + " return instance;", + "}" + ] + where + assignments ps = go (remove (isUnit . snd) ps) + where + go [] = "" + go xobjs = joinLines $ assign allocationMode <$> xobjs + assign alloc (name, ty) = + let accessor = case alloc of + StackAlloc -> "." + HeapAlloc -> "->" + in if isRecType ty + then " instance" ++ accessor ++ name ++ " = " ++ "NULL ;" + else " instance" ++ accessor ++ name ++ " = " ++ name ++ ";" + +---- | Generate a list of types from a deftype declaration. +--initArgListTypes :: [XObj] -> [Ty] +--initArgListTypes xobjs = +-- map (fromJust . xobjToTy . snd) (pairwise xobjs) + +--tokensForRecInit :: AllocationMode -> String -> [XObj] -> [Token] +--tokensForRecInit allocationMode typeName membersXObjs = +-- toTemplate $ +-- unlines +-- [ "$DECL {", +-- case allocationMode of +-- StackAlloc -> case unitless of +-- -- if this is truly a memberless struct, init it to 0; +-- -- This can happen, e.g. in cases where *all* members of the struct are of type Unit. +-- -- Since we do not generate members for Unit types. +-- [] -> " $p instance = {};" +-- _ -> " $p instance;" +-- HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", +-- assignments membersXObjs, +-- recAssignment recmembers, +-- " return instance;", +-- "}" +-- ] +-- where +-- recmembers = filter (isRecType . snd) (memberXObjsToPairs membersXObjs) +-- assignments [] = " instance.__dummy = 0;" +-- assignments _ = go unitless +-- where +-- go [] = "" +-- go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs +-- unitless = remove isRecType (remove (isUnit . snd) (memberXObjsToPairs membersXObjs)) +-- recAssignment xs = +-- +--memberAssignment :: AllocationMode -> String -> String +--memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";" +-- where +-- sep = case allocationMode of +-- StackAlloc -> "." +-- HeapAlloc -> "->" + + +-- +---- | The template for the 'init' and 'new' functions for a generic deftype. +--genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder) +--genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = +-- defineTypeParameterizedTemplate templateCreator path t docs +-- where +-- path = SymPath pathStrings "init" +-- t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy +-- docs = "creates a `" ++ show originalStructTy ++ "`." +-- templateCreator = TemplateCreator $ +-- \typeEnv env -> +-- Template +-- (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) +-- ( \(FuncTy _ concreteStructTy _) -> +-- let mappings = unifySignatures originalStructTy concreteStructTy +-- correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs +-- memberPairs = memberXObjsToPairs correctedMembers +-- in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")") +-- ) +-- ( \(FuncTy _ concreteStructTy _) -> +-- let mappings = unifySignatures originalStructTy concreteStructTy +-- correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs +-- in tokensForInit allocationMode (show originalStructTy) correctedMembers +-- ) +-- ( \(FuncTy _ concreteStructTy _) -> +-- case concretizeType typeEnv env concreteStructTy of +-- Left _ -> [] +-- Right ok -> ok +-- ) +--genericInit _ _ _ _ = error "genericinit" diff --git a/src/Scoring.hs b/src/Scoring.hs index 9cf10acfb..8c5a809ef 100644 --- a/src/Scoring.hs +++ b/src/Scoring.hs @@ -88,6 +88,7 @@ depthOfType typeEnv visited selfName theType = -- accounts for unresolved types and scores based on these rather than -- relying on our hardcoded adjustments being correct? maximum (visitType ltTy : visitType retTy : fmap visitType argTys) + 1 + visitType (RecTy p) = visitType p visitType (PointerTy p) = visitType p visitType (RefTy r lt) = max (visitType r) (visitType lt) visitType _ = 1 diff --git a/src/TypePredicates.hs b/src/TypePredicates.hs index 4cde4feaa..e7f6eb208 100644 --- a/src/TypePredicates.hs +++ b/src/TypePredicates.hs @@ -20,6 +20,10 @@ isUnit UnitTy = True isUnit (RefTy UnitTy _) = True isUnit _ = False +isRecType :: Ty -> Bool +isRecType (RecTy _) = True +isRecType _ = False + -- | Is this type a function type? isFunctionType :: Ty -> Bool isFunctionType FuncTy {} = True diff --git a/src/Types.hs b/src/Types.hs index 319d2389e..3a123cc4c 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -58,6 +58,7 @@ data Ty | UnitTy | ModuleTy | PointerTy Ty + | RecTy Ty -- Recursive type, wraps members in a type definition. | RefTy Ty Ty -- second Ty is the lifetime | StaticLifetimeTy | StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters @@ -195,6 +196,7 @@ instance Show Ty where show DynamicTy = "Dynamic" show Universe = "Universe" show CTy = "C" + show (RecTy rec) = "Rec " ++ show rec showMaybeTy :: Maybe Ty -> String showMaybeTy (Just t) = show t @@ -248,6 +250,9 @@ unifySignatures at ct = Map.fromList (unify at ct) | otherwise = [] -- error ("Can't unify " ++ a ++ " with " ++ b) unify (StructTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b) unify (PointerTy a) (PointerTy b) = unify a b + unify (PointerTy a) (RecTy b) = unify a b + unify (RecTy a) (PointerTy b) = unify a b + unify (RecTy a) (RecTy b) = unify a b unify (PointerTy _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b) unify (RefTy a ltA) (RefTy b ltB) = unify a b ++ unify ltA ltB unify (RefTy _ _) _ = [] -- error ("Can't unify " ++ show a ++ " with " ++ show b) @@ -280,6 +285,9 @@ areUnifiable (StructTy (VarTy _) args) (RefTy _ _) | otherwise = False areUnifiable (StructTy _ _) _ = False areUnifiable (PointerTy a) (PointerTy b) = areUnifiable a b +areUnifiable (RecTy a) (RecTy b) = areUnifiable a b +areUnifiable (RecTy a) (PointerTy b) = areUnifiable a b +areUnifiable (PointerTy a) (RecTy b) = areUnifiable a b areUnifiable (PointerTy _) _ = False areUnifiable (RefTy a ltA) (RefTy b ltB) = areUnifiable a b && areUnifiable ltA ltB areUnifiable RefTy {} _ = False @@ -326,6 +334,7 @@ replaceTyVars mappings t = (RefTy a lt) -> replaceTyVars mappings (RefTy a lt) _ -> StructTy (replaceTyVars mappings name) (fmap (replaceTyVars mappings) tyArgs) (PointerTy x) -> PointerTy (replaceTyVars mappings x) + (RecTy x) -> PointerTy (replaceTyVars mappings x) (RefTy x lt) -> RefTy (replaceTyVars mappings x) (replaceTyVars mappings lt) _ -> t diff --git a/src/TypesToC.hs b/src/TypesToC.hs index 6fc4778a2..9290962d6 100644 --- a/src/TypesToC.hs +++ b/src/TypesToC.hs @@ -27,6 +27,7 @@ tyToCRawFunctionPtrFix t = tyToCManglePtr False t tyToCManglePtr :: Bool -> Ty -> String tyToCManglePtr b (PointerTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*") +tyToCManglePtr b (RecTy p) = tyToCManglePtr b p ++ (if b then mangle "*" else "*") tyToCManglePtr b (RefTy r _) = tyToCManglePtr b r ++ (if b then mangle "*" else "*") tyToCManglePtr _ ty = f ty where @@ -55,4 +56,5 @@ tyToCManglePtr _ ty = f ty f (PointerTy _) = err "pointers" f (RefTy _ _) = err "references" f CTy = "c_code" -- Literal C; we shouldn't emit anything. + f (RecTy _) = err "recty" err s = error ("Can't emit the type of " ++ s ++ ".") diff --git a/src/Validate.hs b/src/Validate.hs index 327f37b51..9ffbeaae9 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -80,7 +80,8 @@ checkKindConsistency candidate = -- | Returns an error if one of the types members can't be used as a member. checkMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () -checkMembers typeEnv globalEnv candidate = mapM_ (okXObjForType (typename candidate) (restriction candidate) typeEnv globalEnv (variables candidate) . snd) (pairwise (typemembers candidate)) +checkMembers typeEnv globalEnv candidate = + mapM_ (okXObjForType (typename candidate) (restriction candidate) typeEnv globalEnv (variables candidate) . snd) (pairwise (typemembers candidate)) okXObjForType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError () okXObjForType tyname typeVarRestriction typeEnv globalEnv typeVariables xobj = @@ -134,14 +135,17 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj >> pure () checkStruct (ConcreteNameTy path@(SymPath _ pname)) vars = - case E.getTypeBinder typeEnv pname <> E.findTypeBinder globalEnv path of - Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> - pure () - Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars - Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars - _ -> Left (NotAmongRegisteredTypes ty xobj) + if pname == tyname && length vars == length typeVariables + then foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + else + case E.getTypeBinder typeEnv pname <> E.findTypeBinder globalEnv path of + Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> + pure () + Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + _ -> Left (NotAmongRegisteredTypes ty xobj) where checkInhabitants :: Ty -> Either TypeError () checkInhabitants (StructTy _ vs) = From aa56369cc6ac4e71e5419a8271f033e2c17dc039 Mon Sep 17 00:00:00 2001 From: scottolsen Date: Wed, 13 Oct 2021 20:01:00 -0400 Subject: [PATCH 03/13] 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))))) ``` --- src/Concretize.hs | 4 ++ src/Debug.hs | 18 +++++ src/Deftype.hs | 11 ++- src/Managed.hs | 4 +- src/RecType.hs | 167 +++++++++++++++++++++++++-------------------- src/StructUtils.hs | 14 ++++ 6 files changed, 141 insertions(+), 77 deletions(-) create mode 100644 src/Debug.hs diff --git a/src/Concretize.hs b/src/Concretize.hs index 56baadcd0..5dd3f00c0 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -843,6 +843,8 @@ depsForCopyFunc typeEnv env t = -- | Helper for finding the 'str' function for a type. depsForPrnFunc :: TypeEnv -> Env -> Ty -> [XObj] +depsForPrnFunc typeEnv env (RecTy t) = + depsOfPolymorphicFunction typeEnv env [] "str" (FuncTy [PointerTy t] StringTy StaticLifetimeTy) depsForPrnFunc typeEnv env t = if isManaged typeEnv env t then depsOfPolymorphicFunction typeEnv env [] "prn" (FuncTy [RefTy t (VarTy "q")] StringTy StaticLifetimeTy) @@ -900,6 +902,8 @@ concreteDeleteTakePtr typeEnv env members = -- | Generate the C code for deleting a single member of the deftype. -- | TODO: Should return an Either since this can fail! memberDeletionGeneral :: String -> TypeEnv -> Env -> (String, Ty) -> String +memberDeletionGeneral separator _ _ (memberName, (RecTy _)) = + " " ++ "CARP_FREE(p" ++ separator ++ memberName ++ ");" memberDeletionGeneral separator typeEnv env (memberName, memberType) = case findFunctionForMember typeEnv env "delete" (typesDeleterFunctionType memberType) (memberName, memberType) of FunctionFound functionFullName -> " " ++ functionFullName ++ "(p" ++ separator ++ memberName ++ ");" diff --git a/src/Debug.hs b/src/Debug.hs new file mode 100644 index 000000000..1517edd1c --- /dev/null +++ b/src/Debug.hs @@ -0,0 +1,18 @@ +module Debug where + +import qualified Map +import Obj +import SymPath +import Util + +showEnvBinderValues :: Env -> String +showEnvBinderValues = + joinLines . (map (pretty . binderXObj . snd)) . Map.toList . envBindings + +showContextGlobalValues :: Context -> String +showContextGlobalValues = + (++) "Context Global Bindings:\n" . showEnvBinderValues . contextGlobalEnv + +showBinderInEnv :: Env -> SymPath -> String +showBinderInEnv e spath = + joinLines (map pretty (filter (\p -> (getPath p) == spath) (map (binderXObj . snd) (Map.toList (envBindings e))))) diff --git a/src/Deftype.hs b/src/Deftype.hs index ad8cf2064..f9ab1f999 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -69,7 +69,7 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables ptrmembers = map (recursiveMembersToPointers structTy) rest (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers - okInit <- binderForInit insidePath structTy ptrmembers + okInit <- if (any (isRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy ptrmembers okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers "str" (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers"prn" @@ -125,6 +125,12 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _ (FuncTy [p, t] p StaticLifetimeTy) (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) (FuncTy [p, RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy) + (RecTy t') -> + binders + (FuncTy [RefTy p (VarTy "q")] (RefTy t' (VarTy "q")) StaticLifetimeTy) + (FuncTy [p, t] p StaticLifetimeTy) + (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) + (FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy) _ -> binders (FuncTy [RefTy p (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy) @@ -152,6 +158,7 @@ templatesForSingleMember _ _ _ _ _ = error "templatesforsinglemember" -- | The template for getters of a deftype. templateGetter :: String -> Ty -> Template +templateGetter member t@(RecTy _) = recTemplateGetter member t templateGetter _ UnitTy = Template (FuncTy [RefTy (VarTy "p") (VarTy "q")] UnitTy StaticLifetimeTy) @@ -347,7 +354,7 @@ 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) _ _] = +binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [(XObj (Arr membersXObjs) _ _)] = if isTypeGeneric structTy then Right (genericInit StackAlloc insidePath structTy membersXObjs) else diff --git a/src/Managed.hs b/src/Managed.hs index 0ef1ae52c..c8c17d178 100644 --- a/src/Managed.hs +++ b/src/Managed.hs @@ -7,7 +7,7 @@ import Types -- | Should this type be handled by the memory management system. -- Implementation note: This top-level pattern match should be able to just -- match on all types and see whether they implement 'delete', but for some --- reson that doesn't work. Might need to handle generic types separately? +-- reason that doesn't work. Might need to handle generic types separately? isManaged :: TypeEnv -> Env -> Ty -> Bool isManaged typeEnv globalEnv structTy@StructTy {} = interfaceImplementedForTy typeEnv globalEnv "delete" (FuncTy [structTy] UnitTy StaticLifetimeTy) @@ -17,5 +17,7 @@ isManaged _ _ StringTy = True isManaged _ _ PatternTy = True +isManaged _ _ (RecTy _) = + True isManaged _ _ _ = False diff --git a/src/RecType.hs b/src/RecType.hs index 8ca6dfcf4..25622fc8d 100644 --- a/src/RecType.hs +++ b/src/RecType.hs @@ -3,6 +3,8 @@ module RecType recursiveMembersToPointers, isRecursive, recursiveProductMakeBinder, + recursiveProductInitBinder, + recTemplateGetter, ) where @@ -18,7 +20,7 @@ import Data.Maybe (fromJust) import Concretize import ToTemplate -isRecursive :: Ty -> XObj -> Bool +isRecursive :: Ty -> XObj -> Bool isRecursive structTy@(StructTy _ _) (XObj (Arr members) _ _) = any go members where go :: XObj -> Bool @@ -44,7 +46,7 @@ recursiveMembersToPointers _ xobj = xobj recursiveProductMakeBinder :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) recursiveProductMakeBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = - Right $ + Right $ instanceBinder (SymPath insidePath "make") (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy) @@ -55,6 +57,84 @@ recursiveProductMakeBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [ map (fromJust . xobjToTy . snd) (remove (isRecType . fromJust . xobjToTy . snd) (pairwise xobjs)) recursiveProductMakeBinder _ _ _ = error "TODO" +recursiveProductInitBinder :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) +recursiveProductInitBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = + Right $ + instanceBinder + (SymPath insidePath "init") + (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy) + (recursiveProductInit HeapAlloc structTy membersXObjs) + ("creates a `" ++ show structTy ++ "`.") + where initArgListTypes :: [XObj] -> [Ty] + initArgListTypes xobjs = + map (fixRec . fromJust . xobjToTy . snd) (pairwise xobjs) + fixRec (RecTy t) = t + fixRec t = t +recursiveProductInitBinder _ _ _ = error "TODO" + +-- | The template for the 'make' and 'new' functions for a concrete deftype. +recursiveProductInit :: AllocationMode -> Ty -> [XObj] -> Template +recursiveProductInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = + let pairs = memberXObjsToPairs membersXObjs + unitless = remove (isUnit . snd) + unrec = map go . unitless + go (x, (RecTy t)) = (x, t) + go (x, t) = (x, t) + in Template + (FuncTy (map snd (unrec pairs)) (VarTy "p") StaticLifetimeTy) + ( \(FuncTy _ concreteStructTy _) -> + let mappings = unifySignatures originalStructTy concreteStructTy + correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs + memberPairs = memberXObjsToPairs correctedMembers + in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unrec memberPairs)) ++ ")") + ) + ( \(FuncTy _ concreteStructTy _) -> + let mappings = unifySignatures originalStructTy concreteStructTy + correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs + in productInitTokens allocationMode (show originalStructTy) correctedMembers + ) + (\FuncTy {} -> []) + where memberArg :: (String, Ty) -> String + memberArg (memberName, memberTy) = + tyToCLambdaFix (templatizeTy memberTy) ++ " " ++ memberName + templatizeTy :: Ty -> Ty + templatizeTy (VarTy vt) = VarTy ("$" ++ vt) + templatizeTy (FuncTy argTys retTy ltTy) = FuncTy (map templatizeTy argTys) (templatizeTy retTy) (templatizeTy ltTy) + templatizeTy (StructTy name tys) = StructTy name (map templatizeTy tys) + templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt) + templatizeTy (PointerTy t) = PointerTy (templatizeTy t) + templatizeTy t = t +recursiveProductInit _ _ _ = error "concreteinit" + +productInitTokens :: AllocationMode -> String -> [XObj] -> [Token] +productInitTokens allocationMode typeName membersXObjs = + let pairs = (memberXObjsToPairs membersXObjs) + in toTemplate $ + unlines + [ "$DECL {", + case allocationMode of + StackAlloc -> " $p instance;" + HeapAlloc -> " $p *instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", + assignments pairs, + " return *instance;", + "}" + ] + where + assignments ps = go (remove (isUnit . snd) ps) + where + go [] = "" + go xobjs = joinLines $ assign allocationMode <$> xobjs + assign _ (name, (RecTy _)) = + " instance" ++ "->" ++ name ++ " = " ++ "CARP_MALLOC(sizeof(" ++ typeName ++ "));\n" + ++ " *instance->" ++ name ++ " = " ++ name ++ ";\n" + -- ++ " instance" ++ "->" ++ name ++ " = " ++ "&" ++ name ++ ";\n" + -- ++ " " ++ typeName ++"_delete(" ++ name ++ ");" + assign alloc (name, _) = + let accessor = case alloc of + StackAlloc -> "." + HeapAlloc -> "->" + in " instance" ++ accessor ++ name ++ " = " ++ name ++ ";" + -- | The template for the 'make' and 'new' functions for a concrete deftype. recursiveProductMake :: AllocationMode -> Ty -> [XObj] -> Template recursiveProductMake allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = @@ -104,82 +184,21 @@ productMakeTokens allocationMode typeName membersXObjs = where go [] = "" go xobjs = joinLines $ assign allocationMode <$> xobjs - assign alloc (name, ty) = + assign alloc (name, ty) = let accessor = case alloc of StackAlloc -> "." HeapAlloc -> "->" - in if isRecType ty + in if isRecType ty then " instance" ++ accessor ++ name ++ " = " ++ "NULL ;" else " instance" ++ accessor ++ name ++ " = " ++ name ++ ";" ----- | Generate a list of types from a deftype declaration. ---initArgListTypes :: [XObj] -> [Ty] ---initArgListTypes xobjs = --- map (fromJust . xobjToTy . snd) (pairwise xobjs) - ---tokensForRecInit :: AllocationMode -> String -> [XObj] -> [Token] ---tokensForRecInit allocationMode typeName membersXObjs = --- toTemplate $ --- unlines --- [ "$DECL {", --- case allocationMode of --- StackAlloc -> case unitless of --- -- if this is truly a memberless struct, init it to 0; --- -- This can happen, e.g. in cases where *all* members of the struct are of type Unit. --- -- Since we do not generate members for Unit types. --- [] -> " $p instance = {};" --- _ -> " $p instance;" --- HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", --- assignments membersXObjs, --- recAssignment recmembers, --- " return instance;", --- "}" --- ] --- where --- recmembers = filter (isRecType . snd) (memberXObjsToPairs membersXObjs) --- assignments [] = " instance.__dummy = 0;" --- assignments _ = go unitless --- where --- go [] = "" --- go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs --- unitless = remove isRecType (remove (isUnit . snd) (memberXObjsToPairs membersXObjs)) --- recAssignment xs = --- ---memberAssignment :: AllocationMode -> String -> String ---memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";" --- where --- sep = case allocationMode of --- StackAlloc -> "." --- HeapAlloc -> "->" - +-- | The template for getters of recursive types. +recTemplateGetter :: String -> Ty -> Template +recTemplateGetter member (RecTy t) = + Template + (FuncTy [RefTy (VarTy "p") (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy) + (const (toTemplate ((tyToC (PointerTy t)) ++ " $NAME($(Ref p) p)"))) + (const $ toTemplate ("$DECL { return p->" ++ member ++"; }\n")) + (const []) +recTemplateGetter _ _ = error "rectemplate getter" --- ----- | The template for the 'init' and 'new' functions for a generic deftype. ---genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder) ---genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs = --- defineTypeParameterizedTemplate templateCreator path t docs --- where --- path = SymPath pathStrings "init" --- t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy --- docs = "creates a `" ++ show originalStructTy ++ "`." --- templateCreator = TemplateCreator $ --- \typeEnv env -> --- Template --- (FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy) --- ( \(FuncTy _ concreteStructTy _) -> --- let mappings = unifySignatures originalStructTy concreteStructTy --- correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs --- memberPairs = memberXObjsToPairs correctedMembers --- in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")") --- ) --- ( \(FuncTy _ concreteStructTy _) -> --- let mappings = unifySignatures originalStructTy concreteStructTy --- correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs --- in tokensForInit allocationMode (show originalStructTy) correctedMembers --- ) --- ( \(FuncTy _ concreteStructTy _) -> --- case concretizeType typeEnv env concreteStructTy of --- Left _ -> [] --- Right ok -> ok --- ) ---genericInit _ _ _ _ = error "genericinit" diff --git a/src/StructUtils.hs b/src/StructUtils.hs index feb62fc26..307f25154 100644 --- a/src/StructUtils.hs +++ b/src/StructUtils.hs @@ -4,6 +4,7 @@ import Interfaces import Obj import Polymorphism import Types +import TypesToC data AllocationMode = StackAlloc | HeapAlloc @@ -28,6 +29,13 @@ memberStrCallingConvention strOrPrn typeEnv globalEnv memberTy = -- | Generate C code for converting a member variable to a string and appending it to a buffer. memberPrn :: TypeEnv -> Env -> (String, Ty) -> String +memberPrn _ _ (_, (RecTy t)) = + unlines + [ " temp = \"" ++ tyToC t ++ "\";", + " sprintf(bufferPtr, \"%s \", temp);", + " bufferPtr += strlen(temp) + 1;", + " if(temp) { CARP_FREE(temp); temp = NULL; }" + ] memberPrn typeEnv env (memberName, memberTy) = let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of @@ -52,6 +60,12 @@ memberPrn typeEnv env (memberName, memberTy) = -- | Calculate the size for prn:ing a member of a struct memberPrnSize :: TypeEnv -> Env -> (String, Ty) -> String +memberPrnSize _ _ (_, (RecTy t)) = + unlines + [ " temp = \"" ++ tyToC t ++ "\";", + " size += snprintf(NULL, 0, \"%s \", temp);", + " if(temp) { CARP_FREE(temp); temp = NULL; }" + ] memberPrnSize typeEnv env (memberName, memberTy) = let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of From 284533a6d0ecc76b3674cde6458fae26a11d6a94 Mon Sep 17 00:00:00 2001 From: scottolsen Date: Mon, 18 Oct 2021 15:24:39 -0400 Subject: [PATCH 04/13] fix: initialize recursive types on the stack This is in keeping with the way we handle other structs in Carp. --- src/RecType.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/RecType.hs b/src/RecType.hs index 25622fc8d..4f23c587a 100644 --- a/src/RecType.hs +++ b/src/RecType.hs @@ -63,7 +63,7 @@ recursiveProductInitBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [ instanceBinder (SymPath insidePath "init") (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy) - (recursiveProductInit HeapAlloc structTy membersXObjs) + (recursiveProductInit StackAlloc structTy membersXObjs) ("creates a `" ++ show structTy ++ "`.") where initArgListTypes :: [XObj] -> [Ty] initArgListTypes xobjs = @@ -116,7 +116,7 @@ productInitTokens allocationMode typeName membersXObjs = StackAlloc -> " $p instance;" HeapAlloc -> " $p *instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));", assignments pairs, - " return *instance;", + " return instance;", "}" ] where @@ -125,8 +125,8 @@ productInitTokens allocationMode typeName membersXObjs = go [] = "" go xobjs = joinLines $ assign allocationMode <$> xobjs assign _ (name, (RecTy _)) = - " instance" ++ "->" ++ name ++ " = " ++ "CARP_MALLOC(sizeof(" ++ typeName ++ "));\n" - ++ " *instance->" ++ name ++ " = " ++ name ++ ";\n" + " instance" ++ "." ++ name ++ " = " ++ "CARP_MALLOC(sizeof(" ++ typeName ++ "));\n" + ++ " *instance." ++ name ++ " = " ++ name ++ ";\n" -- ++ " instance" ++ "->" ++ name ++ " = " ++ "&" ++ name ++ ";\n" -- ++ " " ++ typeName ++"_delete(" ++ name ++ ");" assign alloc (name, _) = From 171f292e26f53d51a8edda37487e3340268859dc Mon Sep 17 00:00:00 2001 From: scottolsen Date: Mon, 18 Oct 2021 15:25:48 -0400 Subject: [PATCH 05/13] fix: fix memory error for recursive type str and prn functions Before, we attempted to free some memory that was never allocated (since we just print type string literals for recursive portions of a type). --- src/StructUtils.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/StructUtils.hs b/src/StructUtils.hs index 307f25154..f488aa437 100644 --- a/src/StructUtils.hs +++ b/src/StructUtils.hs @@ -33,8 +33,7 @@ memberPrn _ _ (_, (RecTy t)) = unlines [ " temp = \"" ++ tyToC t ++ "\";", " sprintf(bufferPtr, \"%s \", temp);", - " bufferPtr += strlen(temp) + 1;", - " if(temp) { CARP_FREE(temp); temp = NULL; }" + " bufferPtr += strlen(temp) + 1;" ] memberPrn typeEnv env (memberName, memberTy) = let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy @@ -63,8 +62,7 @@ memberPrnSize :: TypeEnv -> Env -> (String, Ty) -> String memberPrnSize _ _ (_, (RecTy t)) = unlines [ " temp = \"" ++ tyToC t ++ "\";", - " size += snprintf(NULL, 0, \"%s \", temp);", - " if(temp) { CARP_FREE(temp); temp = NULL; }" + " size += snprintf(NULL, 0, \"%s \", temp);" ] memberPrnSize typeEnv env (memberName, memberTy) = let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy From 4af9259eb383afbd9009416083e70e9b43327ed1 Mon Sep 17 00:00:00 2001 From: scottolsen Date: Mon, 18 Oct 2021 15:32:18 -0400 Subject: [PATCH 06/13] fix: fix memory leak for recursive structs Previously we did not delete the pointers of children of recursive structs, only their immediate member pointers. This commit fixes that issue. Note that this is currently handled as a special case and should be made general. --- src/Concretize.hs | 6 ++++-- src/Managed.hs | 2 -- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Concretize.hs b/src/Concretize.hs index 5dd3f00c0..b1ff23b88 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -902,8 +902,10 @@ concreteDeleteTakePtr typeEnv env members = -- | Generate the C code for deleting a single member of the deftype. -- | TODO: Should return an Either since this can fail! memberDeletionGeneral :: String -> TypeEnv -> Env -> (String, Ty) -> String -memberDeletionGeneral separator _ _ (memberName, (RecTy _)) = - " " ++ "CARP_FREE(p" ++ separator ++ memberName ++ ");" +memberDeletionGeneral separator _ _ (memberName, (RecTy t)) = + " if(p"++ separator ++ memberName ++") {" ++ recur ++ "CARP_FREE(p" ++ separator ++ memberName ++ "); p" ++ separator ++ memberName ++ "= NULL;}" + -- TODO: Brittle. Come up with a better solution. + where recur = tyToC t ++ "_delete(*p" ++ separator ++ memberName ++ "); " memberDeletionGeneral separator typeEnv env (memberName, memberType) = case findFunctionForMember typeEnv env "delete" (typesDeleterFunctionType memberType) (memberName, memberType) of FunctionFound functionFullName -> " " ++ functionFullName ++ "(p" ++ separator ++ memberName ++ ");" diff --git a/src/Managed.hs b/src/Managed.hs index c8c17d178..b059bcd86 100644 --- a/src/Managed.hs +++ b/src/Managed.hs @@ -17,7 +17,5 @@ isManaged _ _ StringTy = True isManaged _ _ PatternTy = True -isManaged _ _ (RecTy _) = - True isManaged _ _ _ = False From f35761f82fd53d3eea8052c5e48585f31499560b Mon Sep 17 00:00:00 2001 From: scottolsen Date: Mon, 25 Oct 2021 16:42:34 -0400 Subject: [PATCH 07/13] 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. --- CarpHask.cabal | 2 + src/BoxTemplates.hs | 277 +++++++++++++++++++++++++++++++++++++++++++ src/Concretize.hs | 5 +- src/Deftype.hs | 19 +-- src/Emit.hs | 45 +++++-- src/Primitives.hs | 8 +- src/RecType.hs | 99 ++++++++++++++-- src/StartingEnv.hs | 63 +++++++++- src/SumtypeCase.hs | 1 + src/Sumtypes.hs | 10 +- src/ToTemplate.hs | 9 ++ src/TypeCandidate.hs | 30 +++++ src/TypeError.hs | 4 + src/Types.hs | 46 ++++++- src/Validate.hs | 41 +++---- 15 files changed, 591 insertions(+), 68 deletions(-) create mode 100644 src/BoxTemplates.hs create mode 100644 src/TypeCandidate.hs diff --git a/CarpHask.cabal b/CarpHask.cabal index df1a1ec86..744c36bef 100644 --- a/CarpHask.cabal +++ b/CarpHask.cabal @@ -18,6 +18,7 @@ library hs-source-dirs: src exposed-modules: ArrayTemplates, AssignTypes, + BoxTemplates, ColorText, Commands, Concretize, @@ -61,6 +62,7 @@ library SymPath, Template, ToTemplate, + TypeCandidate, TypeError, TypePredicates, Types, diff --git a/src/BoxTemplates.hs b/src/BoxTemplates.hs new file mode 100644 index 000000000..56068877b --- /dev/null +++ b/src/BoxTemplates.hs @@ -0,0 +1,277 @@ +-- | Module BoxTemplates defines Carp's Box type, a container for managed, +-- heap allocated objects. +module BoxTemplates + (delete, + nil, + str, + prn, + BoxTemplates.init, + getter, + copy, + unbox, + ) +where + +import Obj +import Polymorphism +import TypesToC +import Concretize +import Types +import ToTemplate +import Template + +boxTy :: Ty +boxTy = StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")] + +nil :: (String, Binder) +nil = defineTypeParameterizedTemplate templateCreator path t docs + where path = SymPath ["Box"] "nil" + t = FuncTy [] boxTy StaticLifetimeTy + docs = "Initializes a box pointing to nothing." + templateCreator = TemplateCreator $ + \typeEnv env -> + Template + t + (const (toTemplate "Box__$t $NAME ()")) + (\(FuncTy _ _ _) -> + toTemplate $ + unlines + [ "$DECL {", + " Box__$t box;", + " box.data = NULL;", + " return box;", + "}"]) + + ( \(FuncTy _ boxT _) -> + depsForDeleteFunc typeEnv env boxT + ) +init :: (String, Binder) +init = defineTypeParameterizedTemplate templateCreator path t docs + where path = SymPath ["Box"] "init" + t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy + docs = "Initializes a box pointing to value t." + templateCreator = TemplateCreator $ + \_ _ -> + Template + t + (templateLiteral "Box__$t $NAME ($t t)") + (\_ -> + multilineTemplate + ["$DECL {", + " Box__$t instance;", + " instance.data = CARP_MALLOC(sizeof($t));", + " *instance.data = t;", + " return instance;", + "}"]) + (\_ -> []) + +getter :: (String, Binder) +getter = defineTypeParameterizedTemplate templateCreator path t docs + where path = SymPath ["Box"] "deref" + t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy + docs = "Gets the value from a box and deletes the box." + templateCreator = TemplateCreator $ + \_ _ -> + Template + t + (templateLiteral "$t $NAME (Box__$t box)") + (\_ -> + multilineTemplate + ["$DECL {", + " return *box.data;", + "}"]) + (\_ -> []) + +unbox :: (String, Binder) +unbox = defineTypeParameterizedTemplate templateCreator path t docs + where path = SymPath ["Box"] "unbox" + t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy + docs = "Convert a box to a ref and delete the box." + templateCreator = TemplateCreator $ + \_ _ -> + Template + t + (templateLiteral "$t* $NAME(Box__$t* box)") + (\_ -> + multilineTemplate + [ "$DECL {", + " return box->data;", + "}" + ]) + (\_ -> []) + +copy :: (String, Binder) +copy = defineTypeParameterizedTemplate templateCreator path t docs + where path = SymPath ["Box"] "copy" + t = FuncTy[(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) StaticLifetimeTy + docs = "copies a box." + templateCreator = TemplateCreator $ + \tenv env -> + Template + t + (templateLiteral "Box__$t $NAME (Box__$t* box)") + (\(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> + innerCopy tenv env inner) + (\(FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> + depsForCopyFunc tenv env inner + ++ depsForDeleteFunc tenv env boxType) + innerCopy typeEnv valEnv innerTy = + case findFunctionForMemberIncludePrimitives typeEnv valEnv "copy" (typesCopyFunctionType innerTy) ("Inside box.", innerTy) of + FunctionFound functionFullName -> + multilineTemplate + [ "$DECL {", + " Box__$t copy;", + " copy.data = CARP_MALLOC(sizeof($t));", + " if (box->data) {", + " *copy.data = " ++ functionFullName ++ "(box->data);\n", + " } else {", + " copy.data = NULL;", + " }", + " return copy;", + "}" + ] + _ -> + multilineTemplate + [ "$DECL {", + " Box__$t copy;", + " copy.data = CARP_MALLOC(sizeof($t));", + " if (box->data) { ", + " *copy.data = *box->data;", + " } else {", + " copy.data = NULL;", + " }", + " return copy;", + "}" + ] + --FunctionIgnored -> + -- [ "$DECL {", + -- " Box__$t copy;", + -- " copy.data = CARP_MALLOC(sizeof($t));", + -- " *copy.data = box->data;", + -- " return copy;" + -- ] + -- " /* Ignore type inside Array when copying: '" ++ show t ++ "' (no copy function known)*/\n" + +prn :: (String, Binder) +prn = defineTypeParameterizedTemplate templateCreator path t docs + where path = SymPath ["Box"] "prn" + t = FuncTy [boxTy] StringTy StaticLifetimeTy + docs = "Returns a string representation of a Box." + templateCreator = TemplateCreator $ + (\tenv env -> + Template + t + (templateLiteral "String $NAME (Box__$t box)") + (\(FuncTy [boxT] StringTy _) -> multilineTemplate + ["$DECL {", + " if(!box.data){return \"Nil\";}", + " String temp = NULL;", + " int size = 6;", + innerStr tenv env boxT, + -- " bufferPtr += 1;", + " sprintf(bufferPtr, \")\");", + " return buffer;", + "}"]) + (\(FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) -> + depsForPrnFunc tenv env inner + )) + +str :: (String, Binder) +str = defineTypeParameterizedTemplate templateCreator path t docs + where path = SymPath ["Box"] "str" + t = FuncTy [(RefTy boxTy (VarTy "q"))] StringTy StaticLifetimeTy + docs = "Returns a string representation of a Box." + templateCreator = TemplateCreator $ + (\tenv env -> + Template + t + (templateLiteral "String $NAME (Box__$t* box)") + (\(FuncTy [RefTy boxT _] StringTy _) -> multilineTemplate + ["$DECL {", + " if(!box->data){", + " String buffer = CARP_MALLOC(4);", + " sprintf(buffer, \"Nil\");", + " return buffer;", + " }", + " String temp = NULL;", + " int size = 12;", + innerStr tenv env boxT, + " bufferPtr += 1;", + " sprintf(bufferPtr, \")\");", + " return buffer;", + "}"]) + (\(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) -> + depsForPrnFunc tenv env inner + )) + +innerStr :: TypeEnv -> Env -> Ty -> String +innerStr tenv env (StructTy _ [t]) = + case findFunctionForMemberIncludePrimitives tenv env "prn" (typesStrFunctionType tenv env (RefTy t StaticLifetimeTy)) ("Inside box.", t) of + FunctionFound functionFullName -> + unlines + [ " temp = " ++ functionFullName ++ "(box->data);", + " size += snprintf(NULL, 0, \"%s \", temp);", + " String buffer = CARP_MALLOC(size);", + " String bufferPtr = buffer;", + " sprintf(bufferPtr, \"(Box \");", + " bufferPtr += 1;", + " sprintf(bufferPtr, \"%s \", temp);", + " bufferPtr += strlen(temp) + 1;", + " if(temp) {", + " CARP_FREE(temp);", + " temp = NULL;", + " }" + ] + FunctionNotFound _ -> + unlines + [ " temp = \"unknown\";", + " size += snprintf(NULL, 0, \"%s \", temp);", + " String buffer = CARP_MALLOC(size);", + " String bufferPtr = buffer;", + " sprintf(bufferPtr, \"(Box \");", + " bufferPtr += 1;", + " sprintf(bufferPtr, \"%s \", temp);", + " bufferPtr += strlen(temp) + 1;", + " if(temp) {", + " CARP_FREE(temp);", + " temp = NULL;", + " }" + ] + FunctionIgnored -> " /* Ignore type inside Box: '" ++ show t ++ "' ??? */\n" +innerStr _ _ _ = "" + +delete :: (String, Binder) +delete = defineTypeParameterizedTemplate templateCreator path t docs + where path = SymPath ["Box"] "delete" + t = FuncTy [boxTy] UnitTy StaticLifetimeTy + docs = "Deletes a box, freeing its associated memory." + templateCreator = TemplateCreator $ + \tenv env -> + Template + t + (const (toTemplate "void $NAME (Box__$t box)")) + (\(FuncTy [bTy] UnitTy _) -> + toTemplate $ + unlines [ + "$DECL {", + innerDelete tenv env bTy, + "}"]) + ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) -> + depsForDeleteFunc tenv env insideType + ) + +innerDelete :: TypeEnv -> Env -> Ty -> String +innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) = + case findFunctionForMember tenv env "delete" (typesDeleterFunctionType inner) ("Inside box.", inner) of + FunctionFound functionFullName -> + " if(box.data){\n" ++ + " " ++ functionFullName ++ "(((" ++ tyToCLambdaFix inner ++ "*)box.data));\n" ++ + " CARP_FREE(box.data);" ++ + " }\n" + FunctionNotFound msg -> error msg + FunctionIgnored -> + " /* Ignore non-managed type inside Box: '" ++ show inner ++ "' */\n" ++ + " if(box.data){\n" ++ + " CARP_FREE(box.data);" ++ + " }\n" +innerDelete _ _ _ = "" diff --git a/src/Concretize.hs b/src/Concretize.hs index b1ff23b88..e02792653 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -44,6 +44,7 @@ import qualified Set import SumtypeCase import ToTemplate import TypeError +import TypeCandidate import TypePredicates import Types import TypesToC @@ -612,7 +613,7 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs - candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig} + candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env } validateMembers typeEnv env candidate deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers) let xobj = @@ -647,7 +648,7 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases deps = mapM (depsForCase typeEnv env) concretelyTypedCases - candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases } + candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env } in case toCases typeEnv env candidate of -- Don't care about the cases, this is done just for validation. Left err -> Left err Right _ -> diff --git a/src/Deftype.hs b/src/Deftype.hs index f9ab1f999..d199a5cb4 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -18,6 +18,7 @@ import Obj import StructUtils import Template import ToTemplate +import TypeCandidate import TypeError import TypePredicates import Types @@ -31,7 +32,7 @@ import Validate moduleForDeftypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj]) moduleForDeftypeInContext ctx name vars members info = let global = contextGlobalEnv ctx - types = contextTypeEnv ctx + ts = contextTypeEnv ctx path = contextPath ctx inner = either (const Nothing) Just (innermostModuleEnv ctx) previous = @@ -48,7 +49,7 @@ moduleForDeftypeInContext ctx name vars members info = _ -> Left "Non module" ) ) - in moduleForDeftype inner types global path name vars members info previous + in moduleForDeftype inner ts global path name vars members info previous -- | This function creates a "Type Module" with the same name as the type being defined. -- 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 -- 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] - candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = typeVariables, typemembers = []} + candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = typeVariables, typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env} in do mems <- case rest of [XObj (Arr membersXObjs) _ _] -> Right membersXObjs _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) - validateMembers typeEnv env (candidate {typemembers = mems}) let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables ptrmembers = map (recursiveMembersToPointers structTy) rest + innermems <- case ptrmembers of + [XObj (Arr membersXObjs) _ _] -> Right membersXObjs + _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) + okRecursive (candidate {typemembers = mems}) + validateMembers typeEnv env (candidate {typemembers = innermems}) (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers - okInit <- if (any (isRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy ptrmembers + okInit <- if (any (isValueRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy ptrmembers okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers "str" (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers"prn" (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy ptrmembers (okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy ptrmembers let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers - funcs' = if (any (isRecursive structTy) ptrmembers) then (okMake : funcs) else funcs + funcs' = if (any (isValueRecursive structTy) ptrmembers) then (okMake : funcs) else funcs moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs' typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy) deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps @@ -90,7 +95,7 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) insidePath = pathStrings ++ [typeName] - candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = [], typemembers = []} + candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = [], typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env} in do mems <- case rest of [XObj (Arr membersXObjs) _ _] -> Right membersXObjs diff --git a/src/Emit.hs b/src/Emit.hs index 63f3f76df..8a061d6d8 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -16,7 +16,7 @@ import Control.Monad.State import Data.Char (ord) import Data.Functor ((<&>)) import Data.List (intercalate, isPrefixOf, sortOn) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, isJust) import Env import Info import qualified Map @@ -546,10 +546,10 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo _ -> if isNumericLiteral value then do - let literal = freshVar info ++ "_lit" + let literal' = freshVar info ++ "_lit" Just literalTy = xobjTy value - appendToSrc (addIndent indent ++ "static " ++ tyToCLambdaFix literalTy ++ " " ++ literal ++ " = " ++ var ++ ";\n") - appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = &" ++ literal ++ "; // ref\n") + appendToSrc (addIndent indent ++ "static " ++ tyToCLambdaFix literalTy ++ " " ++ literal' ++ " = " ++ var ++ ";\n") + appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = &" ++ literal' ++ "; // ref\n") else appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ fresh ++ " = &" ++ var ++ "; // ref\n") pure fresh -- Deref @@ -819,6 +819,10 @@ memberToDecl :: Ty -> Int -> (XObj, XObj) -> State EmitterState () memberToDecl recty indent (memberName, memberType) = case xobjToTy memberType of -- Handle function pointers as members specially to allow members that are functions referring to the struct itself. + -- Just rt@(StructTy _ [t]) -> + -- if t == recty + -- then appendToSrc (addIndent indent ++ "struct " ++ tyToCLambdaFix rt ++ " " ++ mangle (getName memberName) ++ ";\n") + -- else appendToSrc (addIndent indent ++ tyToCLambdaFix t ++ " " ++ mangle (getName memberName) ++ ";\n") Just rt@(RecTy t) -> if t == recty then appendToSrc (addIndent indent ++ "struct " ++ tyToCLambdaFix rt ++ " " ++ mangle (getName memberName) ++ ";\n") @@ -841,11 +845,13 @@ defStructToDeclaration structTy@(StructTy _ _) _ rest = -- forward declaration for recursive types. when (any (isRecursive structTy) pointerfix) $ do appendToSrc ("// Recursive type \n") - appendToSrc ("typedef struct " ++ tyToC structTy ++ " {\n") + appendToSrc ("struct " ++ tyToC structTy ++ " {\n") when (all (not . isRecursive structTy) pointerfix) $ appendToSrc "typedef struct {\n" - --appendToSrc ("typedef struct " ++ tyToC structTy ++ " " ++ tyToC structTy ++ ";\n") mapM_ typedefCaseToMemberDecl pointerfix - appendToSrc ("} " ++ tyToC structTy ++ ";\n") + appendToSrc "}" + unless (any (isRecursive structTy) pointerfix) + (appendToSrc (" " ++ tyToC structTy)) + appendToSrc ";\n" in if isTypeGeneric structTy then "" -- ("// " ++ show structTy ++ "\n") else emitterSrc (execState visit (EmitterState "")) @@ -854,14 +860,21 @@ defStructToDeclaration _ _ _ = error "defstructtodeclaration" defSumtypeToDeclaration :: Ty -> [XObj] -> String defSumtypeToDeclaration sumTy@(StructTy _ _) rest = let indent = indentAmount + pointerfix = map (recursiveMembersToPointers sumTy) rest visit = do - appendToSrc "typedef struct {\n" + (if (any (isRecursive sumTy) pointerfix) + then do appendToSrc ("// Recursive type \n") + appendToSrc ("struct " ++ tyToC sumTy ++ " {\n") + else appendToSrc "typedef struct {\n") appendToSrc (addIndent indent ++ "union {\n") mapM_ (emitSumtypeCase indent) rest appendToSrc (addIndent indent ++ "char __dummy;\n") appendToSrc (addIndent indent ++ "} u;\n") appendToSrc (addIndent indent ++ "char _tag;\n") - appendToSrc ("} " ++ tyToC sumTy ++ ";\n") + appendToSrc "}" + unless (any (isRecursive sumTy) pointerfix) + (appendToSrc (" " ++ tyToC sumTy)) + appendToSrc ";\n" --appendToSrc ("// " ++ show typeVariables ++ "\n") mapM_ emitSumtypeCaseTagDefinition (zip [0 ..] rest) emitSumtypeCase :: Int -> XObj -> State EmitterState () @@ -899,6 +912,16 @@ defaliasToDeclaration t path = fixer UnitTy = "void*" fixer x = tyToCLambdaFix x +toForwardDeclaration :: Binder -> String +toForwardDeclaration (Binder _ (XObj (Lst xobjs) _ _)) = + case xobjs of + XObj (Deftype _) _ _ : XObj (Sym path _) _ _ : _ -> + "typedef struct " ++ pathToC path ++ " " ++ pathToC path ++ ";\n" + XObj (DefSumtype _) _ _ : XObj (Sym path _) _ _ : _ -> + "typedef struct " ++ pathToC path ++ " " ++ pathToC path ++ ";\n" + _ -> "" +toForwardDeclaration _ = "" + toDeclaration :: Binder -> String toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ ty)) = case xobjs of @@ -1029,6 +1052,8 @@ typeEnvToDeclarations typeEnv global = sorted ++ (foldl folder (addEnvToScore t) (findModules e)) ) allScoredBinders = sortOn fst (foldl folder bindersWithScore mods) + -- recursive binders need to be forward declared. + recursiveBinders = filter (isJust . Meta.getBinderMetaValue "recursive" . snd) allScoredBinders in do okDecls <- mapM @@ -1038,7 +1063,7 @@ typeEnvToDeclarations typeEnv global = (binderToDeclaration typeEnv binder) ) allScoredBinders - pure (concat okDecls) + pure ((concat (map (toForwardDeclaration . snd) recursiveBinders)) ++ (concat okDecls)) envToDeclarations :: TypeEnv -> Env -> Either ToCError String envToDeclarations typeEnv env = diff --git a/src/Primitives.hs b/src/Primitives.hs index 0f9b41254..2d563c3ad 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -27,7 +27,6 @@ import Obj import PrimitiveError import Project import Qualify (Qualified (..), QualifiedPath, getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify) ---import RecType import Reify import Sumtypes import SymPath @@ -38,6 +37,7 @@ import TypePredicates import Types import Util import Web.Browser (openBrowser) +import RecType makeNullaryPrim :: SymPath -> NullaryPrimitiveCallback -> String -> String -> (String, Binder) makeNullaryPrim p = makePrim p . NullaryPrimitive @@ -634,11 +634,15 @@ makeType ctx name vars constructor = let qpath = (qualifyPath ctx (SymPath [] name)) ty = StructTy (ConcreteNameTy (unqualify qpath)) vars (typeX, members, creator) = constructor ty + -- if the type is recursive, tag it so we can easily find such types in the emitter. + tBinder = if any (isRecursive ty) members + then Meta.updateBinderMeta (toBinder typeX) "recursive" trueXObj + else (toBinder typeX) in case ( unwrapTypeErr ctx (creator ctx name vars members Nothing) >>= \(_, modx, deps) -> pure (existingOr ctx qpath modx) >>= \mod' -> - unwrapErr (insertType ctx qpath (toBinder typeX) mod') + unwrapErr (insertType ctx qpath tBinder mod') >>= \c -> pure (foldM (define True) c (map Qualified deps)) ) of Left e -> pure (evalError ctx e (xobjInfo typeX)) diff --git a/src/RecType.hs b/src/RecType.hs index 4f23c587a..a758c7abe 100644 --- a/src/RecType.hs +++ b/src/RecType.hs @@ -1,10 +1,12 @@ module RecType ( recursiveMembersToPointers, - isRecursive, + isValueRecursive, recursiveProductMakeBinder, recursiveProductInitBinder, recTemplateGetter, + okRecursive, + isRecursive, ) where @@ -12,6 +14,7 @@ import Obj import Types import TypePredicates import TypeError +import TypeCandidate import TypesToC import StructUtils import Template @@ -19,30 +22,99 @@ import Util import Data.Maybe (fromJust) import Concretize import ToTemplate +import Validate + +-------------------------------------------------------------------------------- +-- Base indirection recursion + +-- | Returns true if a candidate type definition is a valid instance of recursivity. +-- Types have valid recursion if they refer to themselves through indirection. +okRecursive :: TypeCandidate -> Either TypeError () +okRecursive candidate = + if any go (typemembers candidate) + then validateInterfaceConstraints (candidate { interfaceConstraints = concat $ map go' (typemembers candidate)}) + else Right () + where go :: XObj -> Bool + go (XObj (Sym (SymPath _ name) _) _ _) = name == typename candidate + go (XObj (Lst xs) _ _) = any go xs + go _ = False + go' x@(XObj (Lst _) _ _) = if go x + then case xobjToTy x of + Just t@(PointerTy _) -> recInterfaceConstraints t + Just t@(RefTy _ _) -> recInterfaceConstraints t + Just t@(StructTy _ [_]) -> recInterfaceConstraints t + _ -> [] + else [] + go' _ = [] +-- | Generates interface constraints for a recursive type. +-- The recursive portion of recursive types must be wrapped in a type F that supports indirection. +-- We enforce this with two interfaces: +-- allocate: Heap allocates a value T and wraps it in type F +-- indirect: Returns T from a heap allocated F +recInterfaceConstraints :: Ty -> [InterfaceConstraint] +recInterfaceConstraints t = + let members = tyMembers t + in case members of + [] -> [] + _ -> [ InterfaceConstraint "indirect" [(FuncTy [t] (head members) StaticLifetimeTy)], + InterfaceConstraint "alloc" [(FuncTy [(head members)] t StaticLifetimeTy)] + ] + +-- | Returns true if a type member xobj is recursive (either through indirect recursion or "value" recursion) isRecursive :: Ty -> XObj -> Bool -isRecursive structTy@(StructTy _ _) (XObj (Arr members) _ _) = +isRecursive (StructTy (ConcreteNameTy spath) _) (XObj (Sym path _) _ _) = spath == path +isRecursive rec (XObj (Lst xs) _ _) = any (isRecursive rec) xs +isRecursive rec (XObj (Arr xs) _ _) = any (isRecursive rec) xs +isRecursive _ _ = False + +-------------------------------------------------------------------------------- +-- **Value recursion sugar** +-- +-- By default, all types may only be recursive using indirection. +-- However, it can be slightly inconvenient to have to account for indirection when working with recursive types, e.g. using the box type: +-- +-- (deftype IntList [head Int tail (Box IntList)]) +-- (IntList.init 2 (Box.init (IntList.init 1 (Box.init (IntList.init 0 Nil))))) +-- +-- So, we also support syntactic sugar called "value recursion" that emulates recursive data type support in functional languages +-- +-- (deftype IntList [head Int tail IntList]) +-- (IntList.init 2 (IntList.init 1 (IntList.make 0))) +-- +-- Under the hood, the recursive type is wrapped in a Box (a heap allocated, memory-managed pointer). +-- But we generate initers and other functions for recursive types such that +-- all the box wrapping/unwrapping is handled by the compiler instead of the +-- user. + +-- | Returns true if this type is a "value-recursive" type. +isValueRecursive :: Ty -> XObj -> Bool +isValueRecursive structTy@(StructTy _ _) (XObj (Arr members) _ _) = any go members where go :: XObj -> Bool + go (XObj (Lst xs) _ _) = any go xs go xobj = case xobjTy xobj of Just (RecTy rec) -> rec == structTy _ -> False -isRecursive _ _ = False +isValueRecursive _ _ = False --- | Converts member xobjs in a type definition that refer to the type into pointers +-- | Converts member xobjs in a type definition that refer to the type into pointers. recursiveMembersToPointers :: Ty -> XObj -> XObj recursiveMembersToPointers rec (XObj (Arr members) ai at) = (XObj (Arr (map go members)) ai at) where go :: XObj -> XObj - go x@(XObj (Sym spath _) i _) = if show spath == tyname - then (XObj (Lst [XObj (Sym (SymPath [] "RecTy") Symbol) i (Just (RecTy rec)), x]) i (Just (RecTy rec))) - else x - go x = x - tyname = getStructName rec + go x = case xobjToTy x of + Just s@(StructTy _ _) -> convert s + _ -> x + where convert inner = if inner == rec + then (XObj (Lst [XObj (Sym (SymPath [] "RecTy") Symbol) (xobjInfo x) (Just (RecTy rec)), (XObj (Sym (getStructPath rec) Symbol) (xobjInfo x) (Just rec))]) (xobjInfo x) (Just (RecTy rec))) + else x +recursiveMembersToPointers rec (XObj (Lst [name, arr@(XObj (Arr _) _ _)]) li lt) = + (XObj (Lst [name, (recursiveMembersToPointers rec arr)]) li lt) recursiveMembersToPointers _ xobj = xobj -------------------------------------------------------------------------------- --- Recursive product types +-- Value recursive product types recursiveProductMakeBinder :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder) recursiveProductMakeBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] = @@ -69,6 +141,7 @@ recursiveProductInitBinder insidePath structTy@(StructTy (ConcreteNameTy _) _) [ initArgListTypes xobjs = map (fixRec . fromJust . xobjToTy . snd) (pairwise xobjs) fixRec (RecTy t) = t + fixRec (StructTy name rest) = (StructTy name (map fixRec rest)) fixRec t = t recursiveProductInitBinder _ _ _ = error "TODO" @@ -124,11 +197,13 @@ productInitTokens allocationMode typeName membersXObjs = where go [] = "" go xobjs = joinLines $ assign allocationMode <$> xobjs + -- indirected recursion + assign _ (name, (StructTy tyName [(RecTy _)])) = + " instance" ++ "." ++ name ++ " = " ++ "CARP_MALLOC(sizeof(" ++ typeName ++ "));\n" ++ + " *instance." ++ name ++ " = " ++ show tyName ++ "__indirect(name);\n" assign _ (name, (RecTy _)) = " instance" ++ "." ++ name ++ " = " ++ "CARP_MALLOC(sizeof(" ++ typeName ++ "));\n" ++ " *instance." ++ name ++ " = " ++ name ++ ";\n" - -- ++ " instance" ++ "->" ++ name ++ " = " ++ "&" ++ name ++ ";\n" - -- ++ " " ++ typeName ++"_delete(" ++ name ++ ");" assign alloc (name, _) = let accessor = case alloc of StackAlloc -> "." diff --git a/src/StartingEnv.hs b/src/StartingEnv.hs index aa7896ad6..19c2ecd38 100644 --- a/src/StartingEnv.hs +++ b/src/StartingEnv.hs @@ -14,6 +14,7 @@ import qualified StaticArrayTemplates import Template import ToTemplate import Types +import qualified BoxTemplates -- | These modules will be loaded in order before any other code is evaluated. coreModules :: String -> [String] @@ -52,6 +53,28 @@ arrayModule = ArrayTemplates.templateStrArray ] +boxModule :: Env +boxModule = + Env + {envBindings = bindings, + envParent = Nothing, + envModuleName = Just "Box", + envUseModules = Set.empty, + envMode = ExternalEnv, + envFunctionNestingLevel = 0} + where + bindings = + Map.fromList + [ BoxTemplates.delete, + BoxTemplates.nil, + BoxTemplates.str, + BoxTemplates.init, + BoxTemplates.getter, + BoxTemplates.prn, + BoxTemplates.copy, + BoxTemplates.unbox + ] + -- | The static array module staticArrayModule :: Env staticArrayModule = @@ -506,6 +529,7 @@ startingGlobalEnv noArray = ++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule E.empty) Nothing Nothing))] ++ [("Function", Binder emptyMeta (XObj (Mod functionModule E.empty) Nothing Nothing))] ++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule E.empty) Nothing Nothing))] + ++ [("Box", Binder emptyMeta (XObj (Mod boxModule E.empty) Nothing Nothing))] -- | The type environment (containing deftypes and interfaces) before any code is run. startingTypeEnv :: Env @@ -521,7 +545,14 @@ startingTypeEnv = where bindings = Map.fromList - [ interfaceBinder + [ productTypeBinder + (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) + [XObj (Arr [(XObj (Sym (SymPath [] "data") Symbol) Nothing Nothing), + (XObj (Lst [(XObj (Sym (SymPath [] "Ptr") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "t") Symbol) Nothing Nothing)]) Nothing Nothing)]) + (Just builtInSymbolInfo) + (Just TypeTy)] + builtInSymbolInfo, + interfaceBinder "delete" (FuncTy [VarTy "a"] UnitTy StaticLifetimeTy) ([SymPath ["Array"] "delete", SymPath ["StaticArray"] "delete"] ++ registerFunctionFunctionsWithInterface "delete") @@ -529,17 +560,27 @@ startingTypeEnv = interfaceBinder "copy" (FuncTy [RefTy (VarTy "a") (VarTy "q")] (VarTy "a") StaticLifetimeTy) - ([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy"] ++ registerFunctionFunctionsWithInterface "copy") + ([SymPath ["Array"] "copy", SymPath ["Pointer"] "copy", SymPath ["Box"] "copy"] ++ registerFunctionFunctionsWithInterface "copy") builtInSymbolInfo, interfaceBinder "str" (FuncTy [VarTy "a"] StringTy StaticLifetimeTy) - (SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "str") + (SymPath ["Array"] "str" : SymPath ["StaticArray"] "str" : SymPath ["Box"] "str" : registerFunctionFunctionsWithInterface "str") builtInSymbolInfo, interfaceBinder "prn" (FuncTy [VarTy "a"] StringTy StaticLifetimeTy) - (SymPath ["StaticArray"] "str" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is) + (SymPath ["StaticArray"] "str" : SymPath ["Box"] "prn" : registerFunctionFunctionsWithInterface "prn") -- QUESTION: Where is 'prn' for dynamic Array:s registered? Can't find it... (but it is) + builtInSymbolInfo, + interfaceBinder + "indirect" + (FuncTy [(StructTy (VarTy "a") [(VarTy "t")])] (VarTy "t") StaticLifetimeTy) + [SymPath ["Box"] "deref"] + builtInSymbolInfo, + interfaceBinder + "alloc" + (FuncTy [(VarTy "t")] (StructTy (VarTy "a") [(VarTy "t")]) StaticLifetimeTy) + [SymPath ["Box"] "init"] builtInSymbolInfo ] builtInSymbolInfo = Info (-1) (-1) "Built-in." Set.empty (-1) @@ -552,3 +593,17 @@ registerFunctionFunctionsWithInterface interfaceName = -- | Create a binder for an interface definition. interfaceBinder :: String -> Ty -> [SymPath] -> Info -> (String, Binder) interfaceBinder name t paths i = (name, Binder emptyMeta (defineInterface name t paths (Just i))) + +productTypeBinder :: Ty -> [XObj] -> Info -> (String, Binder) +productTypeBinder t@(StructTy (ConcreteNameTy (SymPath [] name)) _) mems info = (name, Binder emptyMeta xobj) + where xobj = + ( XObj + ( Lst + ( XObj (Deftype t) Nothing Nothing : + XObj (Sym (getStructPath t) Symbol) Nothing Nothing : + mems + ) + ) + (Just info) + (Just TypeTy)) +productTypeBinder _ _ _ = error "product incorrect" diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs index 2a12721ac..b995db5c7 100644 --- a/src/SumtypeCase.hs +++ b/src/SumtypeCase.hs @@ -4,6 +4,7 @@ import Obj import TypeError import Types import Validate +import TypeCandidate data SumtypeCase = SumtypeCase { caseName :: String, diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 58757fb8d..be411a613 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -17,7 +17,8 @@ import TypePredicates import Types import TypesToC import Util -import Validate (TypeVarRestriction (..), TypeCandidate (..)) +import TypeCandidate +import RecType getCase :: [SumtypeCase] -> String -> Maybe SumtypeCase getCase cases caseNameToFind = @@ -28,7 +29,7 @@ getCase cases caseNameToFind = moduleForSumtypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj]) moduleForSumtypeInContext ctx name vars members info = let global = contextGlobalEnv ctx - types = contextTypeEnv ctx + ts = contextTypeEnv ctx path = contextPath ctx inner = either (const Nothing) Just (innermostModuleEnv ctx) previous = @@ -45,16 +46,17 @@ moduleForSumtypeInContext ctx name vars members info = _ -> Left "Non module" ) ) - in moduleForSumtype inner types global path name vars members info previous + in moduleForSumtype inner ts global path name vars members info previous moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj]) moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv = let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) insidePath = pathStrings ++ [typeName] - candidate = TypeCandidate {typename = typeName, variables = typeVariables, restriction = AllowOnlyNamesInScope, typemembers = rest} + candidate = TypeCandidate {typename = typeName, variables = typeVariables, restriction = AllowOnlyNamesInScope, typemembers = rest, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env} in do let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables + okRecursive candidate cases <- toCases typeEnv env candidate okIniters <- initers insidePath structTy cases okTag <- binderForTag insidePath structTy diff --git a/src/ToTemplate.hs b/src/ToTemplate.hs index ac94d8198..fbc0b8363 100644 --- a/src/ToTemplate.hs +++ b/src/ToTemplate.hs @@ -5,6 +5,7 @@ import Parsing import Text.Parsec ((<|>)) import qualified Text.Parsec as Parsec import Util +import Types -- | High-level helper function for creating templates from strings of C code. toTemplate :: String -> [Token] @@ -95,6 +96,14 @@ templateLiteral = const . toTemplate multilineTemplate :: [String] -> [Token] multilineTemplate = toTemplate . unlines +simple :: Ty -> String -> [String] -> Template +simple t declaration body = + Template + t + (templateLiteral declaration) + (\_ -> multilineTemplate body) + (\_ -> []) + templateReturn :: String -> [Token] templateReturn x = multilineTemplate diff --git a/src/TypeCandidate.hs b/src/TypeCandidate.hs new file mode 100644 index 000000000..9154b4985 --- /dev/null +++ b/src/TypeCandidate.hs @@ -0,0 +1,30 @@ +module TypeCandidate where + +import Types +import Obj + +data TypeVarRestriction + = AllowAnyTypeVariableNames -- Used when checking a type found in the code, e.g. (Foo a), any name is OK for 'a' + | AllowOnlyNamesInScope -- Used when checking a type definition, e.g. (deftype (Foo a) [x a]), requires a to be in scope + deriving (Eq) + +data InterfaceConstraint = InterfaceConstraint { + interfaceName :: String, + types :: [Ty] +} deriving Show + +-- | TypeCandidate represents a type that's possibly valid or invalid. +data TypeCandidate = TypeCandidate { + -- the name of the type + typename :: String, + -- a list of all variables in the type head + variables :: [Ty], + -- all members of the type + typemembers :: [XObj], + -- what sort of type variables are permitted. + restriction :: TypeVarRestriction, + -- what interfaces should types satisfy + interfaceConstraints :: [InterfaceConstraint], + candidateTypeEnv :: TypeEnv, + candidateEnv :: Env +} diff --git a/src/TypeError.hs b/src/TypeError.hs index 186097bee..4b8e39bd8 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -9,6 +9,7 @@ import Obj import Project import Text.EditDistance (defaultEditCosts, levenshteinDistance) import Types +import TypeCandidate import Util data TypeError @@ -62,8 +63,11 @@ data TypeError | InconsistentKinds String [XObj] | FailedToAddLambdaStructToTyEnv SymPath XObj | FailedToInstantiateGenericType Ty + | InterfaceNotImplemented [InterfaceConstraint] instance Show TypeError where + show (InterfaceNotImplemented is) = + "One or more types do not implement the interfaces: " ++ show is show (SymbolMissingType xobj env) = "I couldn’t find a type for the symbol '" ++ getName xobj ++ "' at " ++ prettyInfoFromXObj xobj diff --git a/src/Types.hs b/src/Types.hs index 3a123cc4c..2de58b71b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -28,6 +28,9 @@ module Types getNameFromStructName, getStructPath, promoteNumber, + tyMembers, + setMembers, + tyIsRecursive, ) where @@ -82,6 +85,32 @@ data Kind | Higher deriving (Eq, Ord, Show) +-- | Returns the member types of a type. +tyMembers :: Ty -> [Ty] +tyMembers (PointerTy t) = [t] +tyMembers (RefTy t lt) = [t, lt] +tyMembers (StructTy _ mems) = mems +tyMembers (RecTy t) = [t] +tyMembers (FuncTy ts t lt) = ts ++ [t, lt] +tyMembers _ = [] + +-- | Sets the members of a type. +setMembers :: Ty -> [Ty] -> Ty +setMembers t [] = t +setMembers (PointerTy _) ts = (PointerTy (head ts)) +setMembers (RefTy _ lt) ts = (RefTy (head ts) lt) +setMembers (RecTy _) ts = (RecTy (head ts)) +setMembers (StructTy n _) ts = (StructTy n ts) +setMembers (FuncTy _ t lt) ts = (FuncTy ts t lt) +setMembers t _ = t + +tyIsRecursive :: Ty -> Bool +tyIsRecursive t@(StructTy n vars) = any go vars + where go (PointerTy o) = t == o + go (StructTy p vars') = n == p || any go vars' + go _ = False +tyIsRecursive _ = False + tyToKind :: Ty -> Kind tyToKind (StructTy _ _) = Higher tyToKind FuncTy {} = Higher -- the type of functions, consider the (->) constructor in Haskell @@ -89,6 +118,14 @@ tyToKind (PointerTy _) = Higher tyToKind (RefTy _ _) = Higher -- Refs may also be treated as a data constructor tyToKind _ = Base +kindCardinality :: Ty -> Int +kindCardinality (RefTy _ _) = 1 +kindCardinality (PointerTy _) = 1 +kindCardinality (StructTy _ args) = (length args) +kindCardinality (RecTy _ ) = 1 +kindCardinality (FuncTy args _ _) = (length args) +kindCardinality _ = 0 + -- | Check whether or not the kinds of type variables are consistent. -- This function will return Left as soon as a variable is used inconsistently, -- reporting which variable triggered the issue. @@ -196,7 +233,7 @@ instance Show Ty where show DynamicTy = "Dynamic" show Universe = "Universe" show CTy = "C" - show (RecTy rec) = "Rec " ++ show rec + show (RecTy rec) = "(Rec " ++ show rec ++ ")" showMaybeTy :: Maybe Ty -> String showMaybeTy (Just t) = show t @@ -280,9 +317,10 @@ areUnifiable (StructTy a aArgs) (StructTy b bArgs) areUnifiable (StructTy (VarTy _) aArgs) (FuncTy bArgs _ _) | length aArgs /= length bArgs = False | otherwise = all (== True) (zipWith areUnifiable aArgs bArgs) -areUnifiable (StructTy (VarTy _) args) (RefTy _ _) - | length args == 2 = True - | otherwise = False +areUnifiable s@(StructTy (VarTy _) _) t = + (kindCardinality s) == (kindCardinality t) +areUnifiable t s@(StructTy (VarTy _) _) = + (kindCardinality s) == (kindCardinality t) areUnifiable (StructTy _ _) _ = False areUnifiable (PointerTy a) (PointerTy b) = areUnifiable a b areUnifiable (RecTy a) (RecTy b) = areUnifiable a b diff --git a/src/Validate.hs b/src/Validate.hs index 9ffbeaae9..5193d6bf2 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -10,37 +10,17 @@ import TypeError import TypePredicates import Types import Util +import TypeCandidate +import Interfaces {-# ANN validateMemberCases "HLint: ignore Eta reduce" #-} -data TypeVarRestriction - = AllowAnyTypeVariableNames -- Used when checking a type found in the code, e.g. (Foo a), any name is OK for 'a' - | AllowOnlyNamesInScope -- Used when checking a type definition, e.g. (deftype (Foo a) [x a]), requires a to be in scope - deriving (Eq) - --- | TypeCandidate represents a type that's possibly valid or invalid. -data TypeCandidate = TypeCandidate { - -- the name of the type - typename :: String, - -- a list of all variables in the type head - variables :: [Ty], - -- all members of the type - typemembers :: [XObj], - -- what sort of type variables are permitted. - restriction :: TypeVarRestriction -} - -- | Make sure that the member declarations in a type definition -- | Follow the pattern [ , , ...] -- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies. validateMemberCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () -validateMemberCases typeEnv globalEnv candidate = --mapM_ visit (members candidate) +validateMemberCases typeEnv globalEnv candidate = validateMembers typeEnv globalEnv (candidate {restriction = AllowOnlyNamesInScope}) - -- where - -- visit (XObj (Arr membersXObjs) _ _) = - -- validateMembers typeEnv globalEnv (candidate {restriction = AllowOnlyNamesInScope}) - -- visit xobj = - -- Left (InvalidSumtypeCase xobj) validateMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () validateMembers typeEnv globalEnv candidate = @@ -49,6 +29,14 @@ validateMembers typeEnv globalEnv candidate = (checkMembers typeEnv globalEnv candidate) >> (checkKindConsistency candidate) +validateInterfaceConstraints :: TypeCandidate -> Either TypeError () +validateInterfaceConstraints candidate = + let impls = map go (interfaceConstraints candidate) + in if all (==True) impls + then Right () + else Left $ InterfaceNotImplemented (interfaceConstraints candidate) + where go ic = all (interfaceImplementedForTy (candidateTypeEnv candidate) (candidateEnv candidate) (interfaceName ic)) (types ic) + -- | Returns an error if a type has an uneven number of members. checkUnevenMembers :: TypeCandidate -> Either TypeError () checkUnevenMembers candidate = @@ -108,6 +96,9 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables PointerTy inner -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner xobj >> pure () + --BoxTy inner -> + -- canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner xobj + -- >> pure () -- Struct variables may appear as complete applications or individual -- components in the head of a definition; that is the forms: -- ((Foo (f a b)) [x (f a b)]) @@ -128,12 +119,16 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables struct@(StructTy sname tyVars) -> checkVar struct <> checkStruct sname tyVars v@(VarTy _) -> checkVar v + (RecTy _) -> pure () _ -> Left (InvalidMemberType ty xobj) where checkStruct :: Ty -> [Ty] -> Either TypeError () checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] = canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj >> pure () + checkStruct (ConcreteNameTy (SymPath [] "Box")) [innerType] = + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj + >> pure () checkStruct (ConcreteNameTy path@(SymPath _ pname)) vars = if pname == tyname && length vars == length typeVariables then foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars From 4a281279a83374848bdf2a3a6fae08f9bc993959 Mon Sep 17 00:00:00 2001 From: scottolsen Date: Mon, 25 Oct 2021 17:33:03 -0400 Subject: [PATCH 08/13] feat: support direct recursion sugar for concrete sumtypes Enables users to use "direct" recursion on sumtypes and abstracts away pointers in function signatures such as case initers. --- src/Deftype.hs | 1 + src/Emit.hs | 4 ++-- src/Sumtypes.hs | 24 +++++++++++++++++++----- 3 files changed, 22 insertions(+), 7 deletions(-) diff --git a/src/Deftype.hs b/src/Deftype.hs index d199a5cb4..1f55083ee 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -465,6 +465,7 @@ templatizeTy (VarTy vt) = VarTy ("$" ++ vt) templatizeTy (FuncTy argTys retTy ltTy) = FuncTy (map templatizeTy argTys) (templatizeTy retTy) (templatizeTy ltTy) templatizeTy (StructTy name tys) = StructTy name (map templatizeTy tys) templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt) +templatizeTy (RecTy t) = t templatizeTy (PointerTy t) = PointerTy (templatizeTy t) templatizeTy t = t diff --git a/src/Emit.hs b/src/Emit.hs index 8a061d6d8..0b8e0c36a 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -867,7 +867,7 @@ defSumtypeToDeclaration sumTy@(StructTy _ _) rest = appendToSrc ("struct " ++ tyToC sumTy ++ " {\n") else appendToSrc "typedef struct {\n") appendToSrc (addIndent indent ++ "union {\n") - mapM_ (emitSumtypeCase indent) rest + mapM_ (emitSumtypeCase indent) pointerfix appendToSrc (addIndent indent ++ "char __dummy;\n") appendToSrc (addIndent indent ++ "} u;\n") appendToSrc (addIndent indent ++ "char _tag;\n") @@ -876,7 +876,7 @@ defSumtypeToDeclaration sumTy@(StructTy _ _) rest = (appendToSrc (" " ++ tyToC sumTy)) appendToSrc ";\n" --appendToSrc ("// " ++ show typeVariables ++ "\n") - mapM_ emitSumtypeCaseTagDefinition (zip [0 ..] rest) + mapM_ emitSumtypeCaseTagDefinition (zip [0 ..] pointerfix) emitSumtypeCase :: Int -> XObj -> State EmitterState () emitSumtypeCase ind (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr []) _ _]) _ _) = appendToSrc (addIndent ind ++ "// " ++ caseName ++ "\n") diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index be411a613..14415e415 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -56,8 +56,9 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i candidate = TypeCandidate {typename = typeName, variables = typeVariables, restriction = AllowOnlyNamesInScope, typemembers = rest, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env} in do let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables + ptrFix = map (recursiveMembersToPointers structTy) rest okRecursive candidate - cases <- toCases typeEnv env candidate + cases <- toCases typeEnv env (candidate {typemembers = ptrFix}) okIniters <- initers insidePath structTy cases okTag <- binderForTag insidePath structTy (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str" @@ -91,19 +92,21 @@ binderForCaseInit _ _ _ = error "binderforcaseinit" concreteCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder) concreteCaseInit allocationMode insidePath structTy sumtypeCase = - instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (caseTys sumtypeCase) structTy StaticLifetimeTy) template doc + instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (map removeRec (caseTys sumtypeCase)) structTy StaticLifetimeTy) template doc where doc = "creates a `" ++ caseName sumtypeCase ++ "`." template = Template - (FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy) + (FuncTy (map removeRec (caseTys sumtypeCase)) (VarTy "p") StaticLifetimeTy) ( \(FuncTy _ concreteStructTy _) -> let mappings = unifySignatures structTy concreteStructTy - correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) + correctedTys = map (replaceTyVars mappings) (map removeRec (caseTys sumtypeCase)) in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")") ) (const (tokensForCaseInit allocationMode structTy sumtypeCase)) (\FuncTy {} -> []) + removeRec (RecTy t) = t + removeRec t = t genericCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder) genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase = @@ -141,13 +144,15 @@ tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCa StackAlloc -> " $p instance;" HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));", joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless, + joinLines $ recCaseMemberAssignment allocationMode correctedName sumTy . fst <$> recursive, " instance._tag = " ++ tagName sumTy correctedName ++ ";", " return instance;", "}" ] where correctedName = caseName sumtypeCase - unitless = zip anonMemberNames $ remove isUnit (caseTys sumtypeCase) + unitless = remove (isRecType . snd) $ zip anonMemberNames $ remove isUnit (caseTys sumtypeCase) + recursive = filter (isRecType . snd) $ zip anonMemberNames (caseTys sumtypeCase) tokensForCaseInit _ _ _ = error "tokensforcaseinit" caseMemberAssignment :: AllocationMode -> String -> String -> String @@ -158,6 +163,15 @@ caseMemberAssignment allocationMode caseNm memberName = StackAlloc -> ".u." HeapAlloc -> "->u." +recCaseMemberAssignment :: AllocationMode -> String -> Ty -> String -> String +recCaseMemberAssignment allocationMode caseNm sumTy memberName = + " instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));\n" + ++ " *instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = " ++ memberName ++ ";" + where + sep = case allocationMode of + StackAlloc -> ".u." + HeapAlloc -> "->u." + binderForTag :: [String] -> Ty -> Either TypeError (String, Binder) binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy _) _) = Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc From 0adbf44a149fe270eccc50ca3128ba7bdae664fe Mon Sep 17 00:00:00 2001 From: scottolsen Date: Mon, 25 Oct 2021 17:58:21 -0400 Subject: [PATCH 09/13] feat: enable match to handle direct recursion We need to indirect implicitly casted pointers to structs back to their values in order for match to work similarly for recursive types as it does for non-recursive types. --- src/Emit.hs | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/src/Emit.hs b/src/Emit.hs index 71019675c..dd83b9520 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -384,17 +384,29 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo emitCaseMatcher :: (String, String) -> String -> XObj -> Integer -> State EmitterState () emitCaseMatcher (periodOrArrow, ampersandOrNot) caseName (XObj (Sym path _) _ t) index = let Just tt = t - in appendToSrc - ( addIndent indent' ++ tyToCLambdaFix tt ++ " " ++ pathToC path ++ " = " - ++ ampersandOrNot - ++ tempVarToAvoidClash - ++ periodOrArrow - ++ "u." - ++ mangle caseName - ++ ".member" - ++ show index - ++ ";\n" - ) + in if tt == exprTy + then appendToSrc + ( addIndent indent' ++ tyToCLambdaFix tt ++ " " ++ pathToC path ++ " = " + ++ "*" + ++ tempVarToAvoidClash + ++ periodOrArrow + ++ "u." + ++ mangle caseName + ++ ".member" + ++ show index + ++ ";\n" + ) + else appendToSrc + ( addIndent indent' ++ tyToCLambdaFix tt ++ " " ++ pathToC path ++ " = " + ++ ampersandOrNot + ++ tempVarToAvoidClash + ++ periodOrArrow + ++ "u." + ++ mangle caseName + ++ ".member" + ++ show index + ++ ";\n" + ) emitCaseMatcher periodOrArrow caseName (XObj (Lst (XObj (Sym (SymPath _ innerCaseName) _) _ _ : xs)) _ _) index = zipWithM_ (\x i -> emitCaseMatcher periodOrArrow (caseName ++ ".member" ++ show i ++ ".u." ++ removeSuffix innerCaseName) x index) xs ([0 ..] :: [Int]) emitCaseMatcher _ _ xobj _ = From 321b112d5c3fbb6cd74773b8710bf68a421f623c Mon Sep 17 00:00:00 2001 From: scottolsen Date: Tue, 26 Oct 2021 13:14:36 -0400 Subject: [PATCH 10/13] fix: don't generate getters for dummy fields For empty structs, we generate a dummy field for ANSI C compatibility. This field needs to be included in initializers for the struct, but should not be emitted in any other functions. I erroneously included it in other functions in a previous merge. This commit fixes the issue by ensuring the dummy field is only included in the struct initializer. --- src/Deftype.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Deftype.hs b/src/Deftype.hs index 7c10a32f1..9ed1debe3 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -69,18 +69,19 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i [(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 - mems <- case initmembers of + mems <- case rest of [XObj (Arr membersXObjs) _ _] -> Right membersXObjs _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables - ptrmembers = map (recursiveMembersToPointers structTy) initmembers + ptrmembers = map (recursiveMembersToPointers structTy) rest + ptrinitmembers = map (recursiveMembersToPointers structTy) initmembers innermems <- case ptrmembers of [XObj (Arr membersXObjs) _ _] -> Right membersXObjs _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) okRecursive (candidate {typemembers = mems}) validateMembers typeEnv env (candidate {typemembers = innermems}) (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers - okInit <- if (any (isValueRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrmembers else binderForInit insidePath structTy initmembers + okInit <- if (any (isValueRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrinitmembers else binderForInit insidePath structTy initmembers okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers "str" (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy ptrmembers"prn" From 6ada67d6d12f490c95dfe19ebdf69f5144127a8f Mon Sep 17 00:00:00 2001 From: scottolsen Date: Tue, 26 Oct 2021 13:57:35 -0400 Subject: [PATCH 11/13] fix: exclude generic types from recursivity checks Our current recursion check introduced a bug whereby generic types receiving instances of themselves e.g. `(Trivial t)` would be identified as recursive and generate incorrect type emissions. For now, we simply don't consider generic types as recursive, though a future change will add recursivity support for these types as well. --- src/RecType.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/RecType.hs b/src/RecType.hs index a758c7abe..448ab78d9 100644 --- a/src/RecType.hs +++ b/src/RecType.hs @@ -63,7 +63,7 @@ recInterfaceConstraints t = -- | Returns true if a type member xobj is recursive (either through indirect recursion or "value" recursion) isRecursive :: Ty -> XObj -> Bool -isRecursive (StructTy (ConcreteNameTy spath) _) (XObj (Sym path _) _ _) = spath == path +isRecursive (StructTy (ConcreteNameTy spath) []) (XObj (Sym path _) _ _) = spath == path isRecursive rec (XObj (Lst xs) _ _) = any (isRecursive rec) xs isRecursive rec (XObj (Arr xs) _ _) = any (isRecursive rec) xs isRecursive _ _ = False From a0c884bda4d3efe7082bf6310384f8681c253ebb Mon Sep 17 00:00:00 2001 From: scottolsen Date: Tue, 26 Oct 2021 17:27:56 -0400 Subject: [PATCH 12/13] refactor: alter type candidate, use it as an interface boundary Instead of passing types and members separately to routines, we use type candidates as input to recursivity checks. This simplifies both validation and recursiveness checking on types and abstracts away differences in structure between sum type and product type members. I also had to adjust some test output, will restore them in a future commit. --- src/Concretize.hs | 44 ++++------ src/Deftype.hs | 13 ++- src/Emit.hs | 28 ++++--- src/Primitives.hs | 11 ++- src/RecType.hs | 66 ++++++++------- src/SumtypeCase.hs | 36 +++----- src/Sumtypes.hs | 5 +- src/TypeCandidate.hs | 55 +++++++++++- src/TypeError.hs | 8 +- src/Validate.hs | 83 ++++++++----------- ...type_var_not_in_scope.carp.output.expected | 2 +- ...type_var_not_in_scope.carp.output.expected | 2 +- 12 files changed, 194 insertions(+), 159 deletions(-) diff --git a/src/Concretize.hs b/src/Concretize.hs index e02792653..bed846c7d 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -613,8 +613,8 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs - candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env } - validateMembers typeEnv env candidate + candidate <- (fromDeftype (getStructName originalStructTy) renamedOrig typeEnv env validMembers) + validateMembers (candidate {restriction = AllowAnyTypeVariableNames}) deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers) let xobj = XObj @@ -642,30 +642,22 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 - in case solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] of - Left e -> error (show e) - Right mappings -> - let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases - concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases - deps = mapM (depsForCase typeEnv env) concretelyTypedCases - candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env } - in case toCases typeEnv env candidate of -- Don't care about the cases, this is done just for validation. - Left err -> Left err - Right _ -> - case deps of - Right okDeps -> - Right $ - XObj - ( Lst - ( XObj (DefSumtype genericStructTy) Nothing Nothing : - XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : - concretelyTypedCases - ) - ) - (Just dummyInfo) - (Just TypeTy) : - concat okDeps - Left err -> Left err + in do mappings <- replaceLeft (FailedToInstantiateGenericType originalStructTy) (solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym]) + let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases + concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases + candidate <- fromSumtype (getStructName originalStructTy) renamedOrig typeEnv env concretelyTypedCases + _ <- toCases typeEnv env (candidate {restriction = AllowAnyTypeVariableNames}) + deps <- mapM (depsForCase typeEnv env) concretelyTypedCases + pure (XObj + ( Lst + ( XObj (DefSumtype genericStructTy) Nothing Nothing : + XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : + concretelyTypedCases + ) + ) + (Just dummyInfo) + (Just TypeTy) : + concat deps) instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype" -- Resolves dependencies for sumtype cases. diff --git a/src/Deftype.hs b/src/Deftype.hs index 9ed1debe3..b62f26fd8 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -61,7 +61,6 @@ 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] - candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = typeVariables, typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env} 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. @@ -75,11 +74,9 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables ptrmembers = map (recursiveMembersToPointers structTy) rest ptrinitmembers = map (recursiveMembersToPointers structTy) initmembers - innermems <- case ptrmembers of - [XObj (Arr membersXObjs) _ _] -> Right membersXObjs - _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) - okRecursive (candidate {typemembers = mems}) - validateMembers typeEnv env (candidate {typemembers = innermems}) + candidate <- fromDeftype typeName typeVariables typeEnv env mems + validateMembers candidate + okRecursive candidate (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers okInit <- if (any (isValueRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrinitmembers else binderForInit insidePath structTy initmembers okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers @@ -102,12 +99,12 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) insidePath = pathStrings ++ [typeName] - candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = [], typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env} in do mems <- case rest of [XObj (Arr membersXObjs) _ _] -> Right membersXObjs _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy)) - validateMembers typeEnv env (candidate {typemembers = mems}) + candidate <- fromDeftype typeName [] typeEnv env mems + validateMembers candidate let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) [] (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest okInit <- binderForInit insidePath structTy rest diff --git a/src/Emit.hs b/src/Emit.hs index dd83b9520..9d116978d 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -15,6 +15,7 @@ where import Control.Monad.State import Data.Char (ord) import Data.Functor ((<&>)) +import Data.Either (fromRight) import Data.List (intercalate, isPrefixOf, sortOn) import Data.Maybe (fromJust, fromMaybe, isJust) import Env @@ -31,6 +32,7 @@ import Template import TypePredicates import Types import TypesToC +import TypeCandidate import Util addIndent :: Int -> String @@ -843,7 +845,7 @@ memberToDecl recty indent (memberName, memberType) = Nothing -> error ("Invalid memberType: " ++ show memberType) defStructToDeclaration :: Ty -> SymPath -> [XObj] -> String -defStructToDeclaration structTy@(StructTy _ _) _ rest = +defStructToDeclaration structTy@(StructTy _ vars) _ rest@[XObj (Arr mems) _ _] = let indent = indentAmount typedefCaseToMemberDecl :: XObj -> State EmitterState [()] -- ANSI C doesn't allow empty structs, insert a dummy member to keep the compiler happy. @@ -851,17 +853,18 @@ defStructToDeclaration structTy@(StructTy _ _) _ rest = typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl structTy indent) (remove (isUnit . fromJust . xobjToTy . snd) (pairwise members)) typedefCaseToMemberDecl _ = error "Invalid case in typedef." pointerfix = map (recursiveMembersToPointers structTy) rest + candidate = fromDeftype (getStructName structTy) vars empty empty mems + isRec = fromRight False (fmap isRecursive candidate) -- Note: the names of types are not namespaced visit = do -- forward declaration for recursive types. - when (any (isRecursive structTy) pointerfix) $ + when isRec $ do appendToSrc ("// Recursive type \n") appendToSrc ("struct " ++ tyToC structTy ++ " {\n") - when (all (not . isRecursive structTy) pointerfix) $ appendToSrc "typedef struct {\n" + when (not isRec) $ appendToSrc "typedef struct {\n" mapM_ typedefCaseToMemberDecl pointerfix appendToSrc "}" - unless (any (isRecursive structTy) pointerfix) - (appendToSrc (" " ++ tyToC structTy)) + unless isRec (appendToSrc (" " ++ tyToC structTy)) appendToSrc ";\n" in if isTypeGeneric structTy then "" -- ("// " ++ show structTy ++ "\n") @@ -869,22 +872,23 @@ defStructToDeclaration structTy@(StructTy _ _) _ rest = defStructToDeclaration _ _ _ = error "defstructtodeclaration" defSumtypeToDeclaration :: Ty -> [XObj] -> String -defSumtypeToDeclaration sumTy@(StructTy _ _) rest = +defSumtypeToDeclaration sumTy@(StructTy _ vars) rest = let indent = indentAmount pointerfix = map (recursiveMembersToPointers sumTy) rest + candidate = fromSumtype (getStructName sumTy) vars empty empty rest + isRec = (fromRight False (fmap isRecursive candidate)) visit = do - (if (any (isRecursive sumTy) pointerfix) - then do appendToSrc ("// Recursive type \n") - appendToSrc ("struct " ++ tyToC sumTy ++ " {\n") - else appendToSrc "typedef struct {\n") + if isRec + then do appendToSrc ("// Recursive type \n") + appendToSrc ("struct " ++ tyToC sumTy ++ " {\n") + else appendToSrc "typedef struct {\n" appendToSrc (addIndent indent ++ "union {\n") mapM_ (emitSumtypeCase indent) pointerfix appendToSrc (addIndent indent ++ "char __dummy;\n") appendToSrc (addIndent indent ++ "} u;\n") appendToSrc (addIndent indent ++ "char _tag;\n") appendToSrc "}" - unless (any (isRecursive sumTy) pointerfix) - (appendToSrc (" " ++ tyToC sumTy)) + unless isRec (appendToSrc (" " ++ tyToC sumTy)) appendToSrc ";\n" --appendToSrc ("// " ++ show typeVariables ++ "\n") mapM_ emitSumtypeCaseTagDefinition (zip [0 ..] pointerfix) diff --git a/src/Primitives.hs b/src/Primitives.hs index d246b74e9..0276934e8 100644 --- a/src/Primitives.hs +++ b/src/Primitives.hs @@ -15,7 +15,7 @@ import Data.List (foldl') import Data.Maybe (fromJust, fromMaybe) import Deftype import Emit -import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder) +import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder, empty) import EvalError import Infer import Info @@ -35,6 +35,7 @@ import ToTemplate import TypeError import TypePredicates import Types +import TypeCandidate import Util import Web.Browser (openBrowser) import RecType @@ -647,8 +648,14 @@ makeType ctx name vars constructor = let qpath = (qualifyPath ctx (SymPath [] name)) ty = StructTy (ConcreteNameTy (unqualify qpath)) vars (typeX, members, creator) = constructor ty + mems = case members of + [XObj (Arr xs) _ _] -> xs + --(Lst xs) -> xs + _ -> members + candidate = fromDeftype name vars Env.empty Env.empty mems <> fromSumtype name vars Env.empty Env.empty mems + isRec = fromRight False (fmap isRecursive candidate) -- if the type is recursive, tag it so we can easily find such types in the emitter. - tBinder = if any (isRecursive ty) members + tBinder = if isRec then Meta.updateBinderMeta (toBinder typeX) "recursive" trueXObj else (toBinder typeX) in case ( unwrapTypeErr ctx (creator ctx name vars members Nothing) diff --git a/src/RecType.hs b/src/RecType.hs index 448ab78d9..bf32a88d3 100644 --- a/src/RecType.hs +++ b/src/RecType.hs @@ -1,3 +1,4 @@ +-- | Module RecType defines routines for working with recursive data types. module RecType ( recursiveMembersToPointers, @@ -24,6 +25,29 @@ import Concretize import ToTemplate import Validate +-- | Returns true if a type candidate is recursive. +isRecursive :: TypeCandidate -> Bool +isRecursive candidate = + let memberTypes = concat $ map snd (typemembers candidate) + vars = variables candidate + name = typename candidate + in any (check name vars) memberTypes + where check :: String -> [Ty] -> Ty -> Bool + check name vars t = isDirectRecursion name vars t || isIndirectRecursion name vars t + +isDirectRecursion :: String -> [Ty] -> Ty -> Bool +isDirectRecursion name vars (StructTy (ConcreteNameTy (SymPath [] n)) rest) = + (n == name && vars == rest) +isDirectRecursion name vars (RecTy t) = isDirectRecursion name vars t +isDirectRecursion _ _ _ = False + +isIndirectRecursion :: String -> [Ty] -> Ty -> Bool +isIndirectRecursion name vars t@(StructTy _ rest) = + not (isDirectRecursion name vars t) && any (isDirectRecursion name vars) rest +isIndirectRecursion name vars (PointerTy t) = isDirectRecursion name vars t +isIndirectRecursion name vars (RefTy t _) = isDirectRecursion name vars t +isIndirectRecursion _ _ _ = False + -------------------------------------------------------------------------------- -- Base indirection recursion @@ -31,42 +55,24 @@ import Validate -- Types have valid recursion if they refer to themselves through indirection. okRecursive :: TypeCandidate -> Either TypeError () okRecursive candidate = - if any go (typemembers candidate) - then validateInterfaceConstraints (candidate { interfaceConstraints = concat $ map go' (typemembers candidate)}) - else Right () - where go :: XObj -> Bool - go (XObj (Sym (SymPath _ name) _) _ _) = name == typename candidate - go (XObj (Lst xs) _ _) = any go xs - go _ = False - go' x@(XObj (Lst _) _ _) = if go x - then case xobjToTy x of - Just t@(PointerTy _) -> recInterfaceConstraints t - Just t@(RefTy _ _) -> recInterfaceConstraints t - Just t@(StructTy _ [_]) -> recInterfaceConstraints t - _ -> [] - else [] - go' _ = [] + let name = typename candidate + vars = variables candidate + memberTypes = concat $ map snd (typemembers candidate) + recursives = (filter (isIndirectRecursion name vars) memberTypes) + ty = StructTy (ConcreteNameTy (SymPath [] name)) vars + constraints = map (recInterfaceConstraints ty) recursives + in validateInterfaceConstraints (candidate {interfaceConstraints = concat constraints}) -- | Generates interface constraints for a recursive type. -- The recursive portion of recursive types must be wrapped in a type F that supports indirection. -- We enforce this with two interfaces: -- allocate: Heap allocates a value T and wraps it in type F -- indirect: Returns T from a heap allocated F -recInterfaceConstraints :: Ty -> [InterfaceConstraint] -recInterfaceConstraints t = - let members = tyMembers t - in case members of - [] -> [] - _ -> [ InterfaceConstraint "indirect" [(FuncTy [t] (head members) StaticLifetimeTy)], - InterfaceConstraint "alloc" [(FuncTy [(head members)] t StaticLifetimeTy)] - ] - --- | Returns true if a type member xobj is recursive (either through indirect recursion or "value" recursion) -isRecursive :: Ty -> XObj -> Bool -isRecursive (StructTy (ConcreteNameTy spath) []) (XObj (Sym path _) _ _) = spath == path -isRecursive rec (XObj (Lst xs) _ _) = any (isRecursive rec) xs -isRecursive rec (XObj (Arr xs) _ _) = any (isRecursive rec) xs -isRecursive _ _ = False +recInterfaceConstraints :: Ty -> Ty -> [InterfaceConstraint] +recInterfaceConstraints recTy t = + [ InterfaceConstraint "indirect" [(FuncTy [t] recTy StaticLifetimeTy)], + InterfaceConstraint "alloc" [(FuncTy [recTy] t StaticLifetimeTy)] + ] -------------------------------------------------------------------------------- -- **Value recursion sugar** diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs index b995db5c7..9d69a1cf3 100644 --- a/src/SumtypeCase.hs +++ b/src/SumtypeCase.hs @@ -15,28 +15,14 @@ data SumtypeCase = SumtypeCase toCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError [SumtypeCase] toCases typeEnv globalEnv candidate = mapM (toCase (typename candidate) typeEnv globalEnv (restriction candidate) (variables candidate)) (typemembers candidate) -toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase -toCase tyname typeEnv globalEnv varrestriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] pname) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = - let tys = map xobjToTy tyXObjs - in case sequence tys of - Nothing -> - Left (InvalidSumtypeCase x) - Just okTys -> - let validated = map (\t -> canBeUsedAsMemberType tyname varrestriction typeEnv globalEnv typeVars t x) okTys - in case sequence validated of - Left e -> - Left e - Right _ -> - Right $ - SumtypeCase - { caseName = pname, - caseTys = okTys - } -toCase _ _ _ _ _ (XObj (Sym (SymPath [] pname) Symbol) _ _) = - Right $ - SumtypeCase - { caseName = pname, - caseTys = [] - } -toCase _ _ _ _ _ x = - Left (InvalidSumtypeCase x) +toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> (String, [Ty]) -> Either TypeError SumtypeCase +toCase tyname typeEnv globalEnv varrestriction typeVars member = + let validated = mapM (\t -> canBeUsedAsMemberType tyname varrestriction typeEnv globalEnv typeVars t) (snd member) + in case validated of + Left e -> Left e + Right _ -> + Right $ + SumtypeCase + { caseName = fst member, + caseTys = snd member + } diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 14415e415..c98690d36 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -53,12 +53,13 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) insidePath = pathStrings ++ [typeName] - candidate = TypeCandidate {typename = typeName, variables = typeVariables, restriction = AllowOnlyNamesInScope, typemembers = rest, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env} in do let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables ptrFix = map (recursiveMembersToPointers structTy) rest + candidate <- fromSumtype typeName typeVariables typeEnv env rest okRecursive candidate - cases <- toCases typeEnv env (candidate {typemembers = ptrFix}) + candidate' <- fromSumtype typeName typeVariables typeEnv env ptrFix + cases <- toCases typeEnv env candidate' okIniters <- initers insidePath structTy cases okTag <- binderForTag insidePath structTy (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str" diff --git a/src/TypeCandidate.hs b/src/TypeCandidate.hs index 9154b4985..0876561e0 100644 --- a/src/TypeCandidate.hs +++ b/src/TypeCandidate.hs @@ -1,7 +1,12 @@ module TypeCandidate where import Types +import TypeError import Obj +import Util + +-------------------------------------------------------------------------------- +-- Data types data TypeVarRestriction = AllowAnyTypeVariableNames -- Used when checking a type found in the code, e.g. (Foo a), any name is OK for 'a' @@ -20,7 +25,7 @@ data TypeCandidate = TypeCandidate { -- a list of all variables in the type head variables :: [Ty], -- all members of the type - typemembers :: [XObj], + typemembers :: [(String, [Ty])], -- what sort of type variables are permitted. restriction :: TypeVarRestriction, -- what interfaces should types satisfy @@ -28,3 +33,51 @@ data TypeCandidate = TypeCandidate { candidateTypeEnv :: TypeEnv, candidateEnv :: Env } + +-------------------------------------------------------------------------------- +-- Constructors + +-- | Constructs a type candidate from the members of a product type definition. +fromDeftype :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> Either TypeError TypeCandidate +fromDeftype name vars tenv env members = + let tMembers = mapM go (pairwise members) + candidate = TypeCandidate { + typename = name, + variables = vars, + typemembers = [], + interfaceConstraints = [], + restriction = AllowOnlyNamesInScope, + candidateTypeEnv = tenv, + candidateEnv = env + } + in if even (length members) + then fmap (\ms -> candidate {typemembers = ms}) tMembers + else Left (UnevenMembers members) + where go :: (XObj, XObj) -> Either TypeError (String, [Ty]) + go ((XObj (Sym (SymPath [] fieldname) _) _ _), tyx) = + case xobjToTy tyx of + Just t -> Right (fieldname, [t]) + Nothing -> Left (NotAType tyx) + go (x, _) = Left (InvalidProductField x) + +-- | Constructs a type candidate from the members of a sum type definition. +fromSumtype :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> Either TypeError TypeCandidate +fromSumtype name vars tenv env members = + let tMembers = mapM go members + candidate = TypeCandidate { + typename = name, + variables = vars, + typemembers = [], + interfaceConstraints = [], + restriction = AllowOnlyNamesInScope, + candidateTypeEnv = tenv, + candidateEnv = env + } + in fmap (\ms -> candidate {typemembers = ms}) tMembers + where go :: XObj -> Either TypeError (String, [Ty]) + go x@(XObj (Lst [XObj (Sym (SymPath [] pname) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = + case mapM xobjToTy tyXObjs of + Just ts -> Right (pname, ts) + Nothing -> Left (InvalidSumtypeCase x) + go (XObj (Sym (SymPath [] pname) Symbol) _ _) = Right (pname, []) + go x = Left (InvalidSumtypeCase x) diff --git a/src/TypeError.hs b/src/TypeError.hs index 837f3114b..718f9baed 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -9,7 +9,6 @@ import Obj import Project import Text.EditDistance (defaultEditCosts, levenshteinDistance) import Types -import TypeCandidate import Util data TypeError @@ -63,7 +62,8 @@ data TypeError | InconsistentKinds String [XObj] | FailedToAddLambdaStructToTyEnv SymPath XObj | FailedToInstantiateGenericType Ty - | InterfaceNotImplemented [InterfaceConstraint] + | InterfaceNotImplemented [String] + | InvalidProductField XObj instance Show TypeError where show (InterfaceNotImplemented is) = @@ -283,6 +283,10 @@ instance Show TypeError where "I failed to read `" ++ pretty xobj ++ "` as a sumtype case at " ++ prettyInfoFromXObj xobj ++ ".\n\nSumtype cases look like this: `(Foo [Int typevar])`" + show (InvalidProductField xobj) = + "I failed to read `" ++ pretty xobj ++ "` as a product field at " + ++ prettyInfoFromXObj xobj + ++ ".\n\nProduct fields look like this: `[field-name Int]`" show (InvalidMemberType t xobj) = "I can’t use the type `" ++ show t ++ "` as a member type at " ++ prettyInfoFromXObj xobj diff --git a/src/Validate.hs b/src/Validate.hs index 5193d6bf2..ffae81724 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -1,85 +1,73 @@ module Validate where import Control.Monad (foldM) -import Data.Function (on) import Data.List (nubBy, (\\)) -import Data.Maybe (fromJust) import qualified Env as E import Obj import TypeError import TypePredicates import Types -import Util import TypeCandidate import Interfaces +import Reify {-# ANN validateMemberCases "HLint: ignore Eta reduce" #-} -- | Make sure that the member declarations in a type definition -- | Follow the pattern [ , , ...] -- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies. -validateMemberCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () -validateMemberCases typeEnv globalEnv candidate = - validateMembers typeEnv globalEnv (candidate {restriction = AllowOnlyNamesInScope}) +validateMemberCases :: TypeCandidate -> Either TypeError () +validateMemberCases candidate = + validateMembers (candidate {restriction = AllowOnlyNamesInScope}) -validateMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () -validateMembers typeEnv globalEnv candidate = - (checkUnevenMembers candidate) >> +-- | Validates whether or not all the members of a type candidate can be used as member types. +validateMembers :: TypeCandidate -> Either TypeError () +validateMembers candidate = (checkDuplicateMembers candidate) >> - (checkMembers typeEnv globalEnv candidate) >> + (checkMembers (candidateTypeEnv candidate) (candidateEnv candidate) candidate) >> (checkKindConsistency candidate) +-- | Validates whether or not a candidate's types implement interfaces. validateInterfaceConstraints :: TypeCandidate -> Either TypeError () validateInterfaceConstraints candidate = let impls = map go (interfaceConstraints candidate) in if all (==True) impls then Right () - else Left $ InterfaceNotImplemented (interfaceConstraints candidate) + else Left $ InterfaceNotImplemented (map interfaceName (interfaceConstraints candidate)) where go ic = all (interfaceImplementedForTy (candidateTypeEnv candidate) (candidateEnv candidate) (interfaceName ic)) (types ic) --- | Returns an error if a type has an uneven number of members. -checkUnevenMembers :: TypeCandidate -> Either TypeError () -checkUnevenMembers candidate = - if even (length (typemembers candidate)) - then Right () - else Left (UnevenMembers (typemembers candidate)) +-------------------------------------------------------------------------------- +-- Private -- | Returns an error if a type has more than one member with the same name. checkDuplicateMembers :: TypeCandidate -> Either TypeError () checkDuplicateMembers candidate = if length fields == length uniqueFields then Right () - else Left (DuplicatedMembers dups) + else Left (DuplicatedMembers (map symbol dups)) where - fields = fst <$> (pairwise (typemembers candidate)) - uniqueFields = nubBy ((==) `on` xobjObj) fields + fields = fmap fst (typemembers candidate) + uniqueFields = nubBy (==) fields dups = fields \\ uniqueFields -- | Returns an error if the type variables in the body of the type and variables in the head of the type are of incompatible kinds. checkKindConsistency :: TypeCandidate -> Either TypeError () checkKindConsistency candidate = case areKindsConsistent varsOnly of - Left var -> Left (InconsistentKinds var (typemembers candidate)) + Left var -> Left (InconsistentKinds var (map reify (concat (map snd (typemembers candidate))))) _ -> pure () where - -- fromJust is safe here; invalid types will be caught in a prior check. - -- TODO: be safer. - varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) (pairwise (typemembers candidate))) + varsOnly = filter isTypeGeneric $ concat (map snd (typemembers candidate)) -- | Returns an error if one of the types members can't be used as a member. checkMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () checkMembers typeEnv globalEnv candidate = - mapM_ (okXObjForType (typename candidate) (restriction candidate) typeEnv globalEnv (variables candidate) . snd) (pairwise (typemembers candidate)) - -okXObjForType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError () -okXObjForType tyname typeVarRestriction typeEnv globalEnv typeVariables xobj = - case xobjToTy xobj of - Just t -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables t xobj - Nothing -> Left (NotAType xobj) + let tys = concat $ map snd (typemembers candidate) + in mapM_ (canBeUsedAsMemberType (typename candidate) (restriction candidate) typeEnv globalEnv (variables candidate)) tys -- | Can this type be used as a member for a deftype? -canBeUsedAsMemberType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError () -canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables ty xobj = +canBeUsedAsMemberType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> Either TypeError () +canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables ty = case ty of UnitTy -> pure () IntTy -> pure () @@ -94,11 +82,8 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables FuncTy {} -> pure () PointerTy UnitTy -> pure () PointerTy inner -> - canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner xobj + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner >> pure () - --BoxTy inner -> - -- canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner xobj - -- >> pure () -- Struct variables may appear as complete applications or individual -- components in the head of a definition; that is the forms: -- ((Foo (f a b)) [x (f a b)]) @@ -120,37 +105,37 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables checkVar struct <> checkStruct sname tyVars v@(VarTy _) -> checkVar v (RecTy _) -> pure () - _ -> Left (InvalidMemberType ty xobj) + _ -> Left (InvalidMemberType ty (reify ty)) where checkStruct :: Ty -> [Ty] -> Either TypeError () checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] = - canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType >> pure () checkStruct (ConcreteNameTy (SymPath [] "Box")) [innerType] = - canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType >> pure () checkStruct (ConcreteNameTy path@(SymPath _ pname)) vars = if pname == tyname && length vars == length typeVariables - then foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + then foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars else case E.getTypeBinder typeEnv pname <> E.findTypeBinder globalEnv path of Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> pure () Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars - _ -> Left (NotAmongRegisteredTypes ty xobj) + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars + _ -> Left (NotAmongRegisteredTypes ty (reify ty)) where checkInhabitants :: Ty -> Either TypeError () checkInhabitants (StructTy _ vs) = if length vs == length vars then pure () - else Left (UninhabitedConstructor ty xobj (length vs) (length vars)) - checkInhabitants _ = Left (InvalidMemberType ty xobj) + else Left (UninhabitedConstructor ty (reify ty) (length vs) (length vars)) + checkInhabitants _ = Left (InvalidMemberType ty (reify ty)) checkStruct v@(VarTy _) vars = - canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables v xobj - >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables v + >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars checkStruct _ _ = error "checkstruct" checkVar :: Ty -> Either TypeError () checkVar variable = @@ -160,7 +145,7 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables AllowOnlyNamesInScope -> if any (isCaptured variable) typeVariables then pure () - else Left (InvalidMemberType ty xobj) + else Left (InvalidMemberType ty (reify ty)) where -- If a variable `a` appears in a higher-order polymorphic form, such as `(f a)` -- `a` may be used as a member, sans `f`, but `f` may not appear diff --git a/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected b/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected index f096c2a6b..d813d3386 100644 --- a/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected +++ b/test/output/test/test-for-errors/deftype_type_var_not_in_scope.carp.output.expected @@ -1 +1 @@ -deftype_type_var_not_in_scope.carp:3:10 deftype_type_var_not_in_scope.carp:3:21 Can't use 'b' as a type for a member variable. +deftype_type_var_not_in_scope.carp:3:10 Can't use 'b' as a type for a member variable. diff --git a/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected b/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected index ab7dab17d..c0cf98171 100644 --- a/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected +++ b/test/output/test/test-for-errors/sumtype_type_var_not_in_scope.carp.output.expected @@ -1 +1 @@ -sumtype_type_var_not_in_scope.carp:3:10 sumtype_type_var_not_in_scope.carp:4:3 Can't use 'x' as a type for a member variable. +sumtype_type_var_not_in_scope.carp:3:10 Can't use 'x' as a type for a member variable. From ef110a3208abc536fa877df1b22a6a30215017a5 Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Fri, 29 Oct 2021 13:41:23 -0400 Subject: [PATCH 13/13] fix: box templates --- src/BoxTemplates.hs | 448 +++++++++++++++++++++++--------------------- 1 file changed, 232 insertions(+), 216 deletions(-) diff --git a/src/BoxTemplates.hs b/src/BoxTemplates.hs index 56068877b..ff4764299 100644 --- a/src/BoxTemplates.hs +++ b/src/BoxTemplates.hs @@ -1,277 +1,293 @@ -- | Module BoxTemplates defines Carp's Box type, a container for managed, --- heap allocated objects. -module BoxTemplates - (delete, - nil, - str, - prn, - BoxTemplates.init, - getter, - copy, - unbox, +-- heap allocated objects. +module BoxTemplates + ( delete, + nil, + str, + prn, + BoxTemplates.init, + getter, + copy, + unbox, ) where +import Concretize import Obj import Polymorphism -import TypesToC -import Concretize -import Types -import ToTemplate import Template +import ToTemplate +import Types +import TypesToC boxTy :: Ty boxTy = StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")] nil :: (String, Binder) nil = defineTypeParameterizedTemplate templateCreator path t docs - where path = SymPath ["Box"] "nil" - t = FuncTy [] boxTy StaticLifetimeTy - docs = "Initializes a box pointing to nothing." - templateCreator = TemplateCreator $ - \typeEnv env -> - Template - t - (const (toTemplate "Box__$t $NAME ()")) - (\(FuncTy _ _ _) -> - toTemplate $ - unlines - [ "$DECL {", - " Box__$t box;", - " box.data = NULL;", - " return box;", - "}"]) - - ( \(FuncTy _ boxT _) -> - depsForDeleteFunc typeEnv env boxT - ) + where + path = SymPath ["Box"] "nil" + t = FuncTy [] boxTy StaticLifetimeTy + docs = "Initializes a box pointing to nothing." + templateCreator = TemplateCreator $ + \typeEnv env -> + Template + t + (const (toTemplate "Box__$t $NAME ()")) + ( \(FuncTy _ _ _) -> + toTemplate $ + unlines + [ "$DECL {", + " Box__$t box;", + " box.data = NULL;", + " return box;", + "}" + ] + ) + ( \(FuncTy _ boxT _) -> + depsForDeleteFunc typeEnv env boxT + ) + init :: (String, Binder) init = defineTypeParameterizedTemplate templateCreator path t docs - where path = SymPath ["Box"] "init" - t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy - docs = "Initializes a box pointing to value t." - templateCreator = TemplateCreator $ - \_ _ -> - Template - t - (templateLiteral "Box__$t $NAME ($t t)") - (\_ -> - multilineTemplate - ["$DECL {", - " Box__$t instance;", - " instance.data = CARP_MALLOC(sizeof($t));", - " *instance.data = t;", - " return instance;", - "}"]) - (\_ -> []) + where + path = SymPath ["Box"] "init" + t = FuncTy [(VarTy "t")] boxTy StaticLifetimeTy + docs = "Initializes a box pointing to value t." + templateCreator = TemplateCreator $ + \_ _ -> + Template + t + (templateLiteral "Box__$t $NAME ($t t)") + ( \_ -> + multilineTemplate + [ "$DECL {", + " Box__$t instance;", + " instance.data = CARP_MALLOC(sizeof($t));", + " *instance.data = t;", + " return instance;", + "}" + ] + ) + (\_ -> []) getter :: (String, Binder) getter = defineTypeParameterizedTemplate templateCreator path t docs - where path = SymPath ["Box"] "deref" - t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy - docs = "Gets the value from a box and deletes the box." - templateCreator = TemplateCreator $ - \_ _ -> - Template - t - (templateLiteral "$t $NAME (Box__$t box)") - (\_ -> - multilineTemplate - ["$DECL {", - " return *box.data;", - "}"]) - (\_ -> []) - -unbox :: (String, Binder) -unbox = defineTypeParameterizedTemplate templateCreator path t docs - where path = SymPath ["Box"] "unbox" - t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy - docs = "Convert a box to a ref and delete the box." - templateCreator = TemplateCreator $ - \_ _ -> - Template - t - (templateLiteral "$t* $NAME(Box__$t* box)") - (\_ -> - multilineTemplate - [ "$DECL {", - " return box->data;", - "}" - ]) - (\_ -> []) - -copy :: (String, Binder) -copy = defineTypeParameterizedTemplate templateCreator path t docs - where path = SymPath ["Box"] "copy" - t = FuncTy[(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) StaticLifetimeTy - docs = "copies a box." - templateCreator = TemplateCreator $ - \tenv env -> - Template - t - (templateLiteral "Box__$t $NAME (Box__$t* box)") - (\(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> - innerCopy tenv env inner) - (\(FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> - depsForCopyFunc tenv env inner - ++ depsForDeleteFunc tenv env boxType) - innerCopy typeEnv valEnv innerTy = - case findFunctionForMemberIncludePrimitives typeEnv valEnv "copy" (typesCopyFunctionType innerTy) ("Inside box.", innerTy) of - FunctionFound functionFullName -> + where + path = SymPath ["Box"] "deref" + t = FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")])] (VarTy "t") StaticLifetimeTy + docs = "Gets the value from a box and deletes the box." + templateCreator = TemplateCreator $ + \_ _ -> + Template + t + (templateLiteral "$t $NAME (Box__$t box)") + ( \_ -> multilineTemplate [ "$DECL {", - " Box__$t copy;", - " copy.data = CARP_MALLOC(sizeof($t));", - " if (box->data) {", - " *copy.data = " ++ functionFullName ++ "(box->data);\n", - " } else {", - " copy.data = NULL;", - " }", - " return copy;", + " return *box.data;", "}" ] - _ -> + ) + (\_ -> []) + +unbox :: (String, Binder) +unbox = defineTypeParameterizedTemplate templateCreator path t docs + where + path = SymPath ["Box"] "unbox" + t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (RefTy (VarTy "t") (VarTy "q")) StaticLifetimeTy + docs = "Convert a box to a ref and delete the box." + templateCreator = TemplateCreator $ + \_ _ -> + Template + t + (templateLiteral "$t* $NAME(Box__$t* box)") + ( \_ -> multilineTemplate [ "$DECL {", - " Box__$t copy;", - " copy.data = CARP_MALLOC(sizeof($t));", - " if (box->data) { ", - " *copy.data = *box->data;", - " } else {", - " copy.data = NULL;", - " }", - " return copy;", + " return box->data;", "}" ] - --FunctionIgnored -> - -- [ "$DECL {", - -- " Box__$t copy;", - -- " copy.data = CARP_MALLOC(sizeof($t));", - -- " *copy.data = box->data;", - -- " return copy;" - -- ] - -- " /* Ignore type inside Array when copying: '" ++ show t ++ "' (no copy function known)*/\n" + ) + (\_ -> []) + +copy :: (String, Binder) +copy = defineTypeParameterizedTemplate templateCreator path t docs + where + path = SymPath ["Box"] "copy" + t = FuncTy [(RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) (VarTy "q"))] (StructTy (ConcreteNameTy (SymPath [] "Box")) [(VarTy "t")]) StaticLifetimeTy + docs = "copies a box." + templateCreator = TemplateCreator $ + \tenv env -> + Template + t + (templateLiteral "Box__$t $NAME (Box__$t* box)") + ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> + innerCopy tenv env inner + ) + ( \(FuncTy [RefTy boxType@(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] _ _) -> + depsForCopyFunc tenv env inner + ++ depsForDeleteFunc tenv env boxType + ) + innerCopy typeEnv valEnv innerTy = + case findFunctionForMemberIncludePrimitives typeEnv valEnv "copy" (typesCopyFunctionType innerTy) ("Inside box.", innerTy) of + FunctionFound functionFullName -> + multilineTemplate + [ "$DECL {", + " Box__$t copy;", + " copy.data = CARP_MALLOC(sizeof($t));", + " if (box->data) {", + " *copy.data = " ++ functionFullName ++ "(box->data);\n", + " } else {", + " copy.data = NULL;", + " }", + " return copy;", + "}" + ] + _ -> + multilineTemplate + [ "$DECL {", + " Box__$t copy;", + " copy.data = CARP_MALLOC(sizeof($t));", + " if (box->data) { ", + " *copy.data = *box->data;", + " } else {", + " copy.data = NULL;", + " }", + " return copy;", + "}" + ] + +--FunctionIgnored -> +-- [ "$DECL {", +-- " Box__$t copy;", +-- " copy.data = CARP_MALLOC(sizeof($t));", +-- " *copy.data = box->data;", +-- " return copy;" +-- ] +-- " /* Ignore type inside Array when copying: '" ++ show t ++ "' (no copy function known)*/\n" prn :: (String, Binder) prn = defineTypeParameterizedTemplate templateCreator path t docs - where path = SymPath ["Box"] "prn" - t = FuncTy [boxTy] StringTy StaticLifetimeTy - docs = "Returns a string representation of a Box." - templateCreator = TemplateCreator $ - (\tenv env -> - Template + where + path = SymPath ["Box"] "prn" + t = FuncTy [boxTy] StringTy StaticLifetimeTy + docs = "Returns a string representation of a Box." + templateCreator = + TemplateCreator $ + ( \tenv env -> + Template t - (templateLiteral "String $NAME (Box__$t box)") - (\(FuncTy [boxT] StringTy _) -> multilineTemplate - ["$DECL {", - " if(!box.data){return \"Nil\";}", - " String temp = NULL;", - " int size = 6;", - innerStr tenv env boxT, - -- " bufferPtr += 1;", - " sprintf(bufferPtr, \")\");", - " return buffer;", - "}"]) - (\(FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) -> + (templateLiteral "String $NAME (Box__$t* box)") + ( \(FuncTy [boxT] StringTy _) -> + multilineTemplate + [ "$DECL {", + " if(!box->data){", + " String buffer = CARP_MALLOC(4);", + " sprintf(buffer, \"Nil\");", + " return buffer;", + " }", + innerStr tenv env boxT, + " return buffer;", + "}" + ] + ) + ( \(FuncTy [(StructTy (ConcreteNameTy (SymPath [] "Box")) [inner])] StringTy _) -> depsForPrnFunc tenv env inner - )) + ) + ) str :: (String, Binder) str = defineTypeParameterizedTemplate templateCreator path t docs - where path = SymPath ["Box"] "str" - t = FuncTy [(RefTy boxTy (VarTy "q"))] StringTy StaticLifetimeTy - docs = "Returns a string representation of a Box." - templateCreator = TemplateCreator $ - (\tenv env -> - Template + where + path = SymPath ["Box"] "str" + t = FuncTy [(RefTy boxTy (VarTy "q"))] StringTy StaticLifetimeTy + docs = "Returns a string representation of a Box." + templateCreator = + TemplateCreator $ + ( \tenv env -> + Template t (templateLiteral "String $NAME (Box__$t* box)") - (\(FuncTy [RefTy boxT _] StringTy _) -> multilineTemplate - ["$DECL {", - " if(!box->data){", - " String buffer = CARP_MALLOC(4);", - " sprintf(buffer, \"Nil\");", - " return buffer;", - " }", - " String temp = NULL;", - " int size = 12;", - innerStr tenv env boxT, - " bufferPtr += 1;", - " sprintf(bufferPtr, \")\");", - " return buffer;", - "}"]) - (\(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) -> + ( \(FuncTy [RefTy boxT _] StringTy _) -> + multilineTemplate + [ "$DECL {", + " if(!box->data){", + " String buffer = CARP_MALLOC(4);", + " sprintf(buffer, \"Nil\");", + " return buffer;", + " }", + innerStr tenv env boxT, + " return buffer;", + "}" + ] + ) + ( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) _] StringTy _) -> depsForPrnFunc tenv env inner - )) + ) + ) innerStr :: TypeEnv -> Env -> Ty -> String innerStr tenv env (StructTy _ [t]) = case findFunctionForMemberIncludePrimitives tenv env "prn" (typesStrFunctionType tenv env (RefTy t StaticLifetimeTy)) ("Inside box.", t) of FunctionFound functionFullName -> unlines - [ " temp = " ++ functionFullName ++ "(box->data);", - " size += snprintf(NULL, 0, \"%s \", temp);", + [ " char* temp = " ++ functionFullName ++ "(box->data);", + " int size = snprintf(NULL, 0, \"(Box %s)\", temp);", " String buffer = CARP_MALLOC(size);", - " String bufferPtr = buffer;", - " sprintf(bufferPtr, \"(Box \");", - " bufferPtr += 1;", - " sprintf(bufferPtr, \"%s \", temp);", - " bufferPtr += strlen(temp) + 1;", + " sprintf(buffer, \"(Box %s)\", temp);", " if(temp) {", " CARP_FREE(temp);", " temp = NULL;", " }" ] - FunctionNotFound _ -> + FunctionNotFound _ -> unlines - [ " temp = \"unknown\";", - " size += snprintf(NULL, 0, \"%s \", temp);", - " String buffer = CARP_MALLOC(size);", - " String bufferPtr = buffer;", - " sprintf(bufferPtr, \"(Box \");", - " bufferPtr += 1;", - " sprintf(bufferPtr, \"%s \", temp);", - " bufferPtr += strlen(temp) + 1;", - " if(temp) {", - " CARP_FREE(temp);", - " temp = NULL;", - " }" + [ " String buffer = CARP_MALLOC(14);", + " sprintf(buffer, \"(Box unknown)\");" ] FunctionIgnored -> " /* Ignore type inside Box: '" ++ show t ++ "' ??? */\n" innerStr _ _ _ = "" -delete :: (String, Binder) +delete :: (String, Binder) delete = defineTypeParameterizedTemplate templateCreator path t docs - where path = SymPath ["Box"] "delete" - t = FuncTy [boxTy] UnitTy StaticLifetimeTy - docs = "Deletes a box, freeing its associated memory." - templateCreator = TemplateCreator $ - \tenv env -> - Template - t - (const (toTemplate "void $NAME (Box__$t box)")) - (\(FuncTy [bTy] UnitTy _) -> - toTemplate $ - unlines [ - "$DECL {", + where + path = SymPath ["Box"] "delete" + t = FuncTy [boxTy] UnitTy StaticLifetimeTy + docs = "Deletes a box, freeing its associated memory." + templateCreator = TemplateCreator $ + \tenv env -> + Template + t + (const (toTemplate "void $NAME (Box__$t box)")) + ( \(FuncTy [bTy] UnitTy _) -> + toTemplate $ + unlines + [ "$DECL {", innerDelete tenv env bTy, - "}"]) - ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) -> - depsForDeleteFunc tenv env insideType - ) + "}" + ] + ) + ( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Box")) [insideType]] UnitTy _) -> + depsForDeleteFunc tenv env insideType + ) -innerDelete :: TypeEnv -> Env -> Ty -> String -innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) = +innerDelete :: TypeEnv -> Env -> Ty -> String +innerDelete tenv env (StructTy (ConcreteNameTy (SymPath [] "Box")) [inner]) = case findFunctionForMember tenv env "delete" (typesDeleterFunctionType inner) ("Inside box.", inner) of FunctionFound functionFullName -> - " if(box.data){\n" ++ - " " ++ functionFullName ++ "(((" ++ tyToCLambdaFix inner ++ "*)box.data));\n" ++ - " CARP_FREE(box.data);" ++ - " }\n" + " if(box.data){\n" + ++ " " + ++ functionFullName + ++ "(((" + ++ tyToCLambdaFix inner + ++ "*)box.data));\n" + ++ " CARP_FREE(box.data);" + ++ " }\n" FunctionNotFound msg -> error msg - FunctionIgnored -> - " /* Ignore non-managed type inside Box: '" ++ show inner ++ "' */\n" ++ - " if(box.data){\n" ++ - " CARP_FREE(box.data);" ++ - " }\n" + FunctionIgnored -> + " /* Ignore non-managed type inside Box: '" ++ show inner ++ "' */\n" + ++ " if(box.data){\n" + ++ " CARP_FREE(box.data);" + ++ " }\n" innerDelete _ _ _ = ""