diff --git a/CarpHask.cabal b/CarpHask.cabal index 8f1a6fe67..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, @@ -47,6 +48,7 @@ library PrimitiveError Project, Qualify, + RecType, Reify, RenderDocs, Repl, @@ -60,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..ff4764299 --- /dev/null +++ b/src/BoxTemplates.hs @@ -0,0 +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, + ) +where + +import Concretize +import Obj +import Polymorphism +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 + ) + +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){", + " 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 + 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;", + " }", + 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 + [ " char* temp = " ++ functionFullName ++ "(box->data);", + " int size = snprintf(NULL, 0, \"(Box %s)\", temp);", + " String buffer = CARP_MALLOC(size);", + " sprintf(buffer, \"(Box %s)\", temp);", + " if(temp) {", + " CARP_FREE(temp);", + " temp = NULL;", + " }" + ] + FunctionNotFound _ -> + unlines + [ " String buffer = CARP_MALLOC(14);", + " sprintf(buffer, \"(Box unknown)\");" + ] + 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 7b4a5462d..bed846c7d 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,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 <- (fromDeftype (getStructName originalStructTy) renamedOrig typeEnv env validMembers) + validateMembers (candidate {restriction = AllowAnyTypeVariableNames}) deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers) let xobj = XObj @@ -640,29 +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 - in case toCases typeEnv env AllowAnyTypeVariableNames renamedOrig concretelyTypedCases 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. @@ -841,6 +836,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) @@ -898,6 +895,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 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/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/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 1ab08b362..b62f26fd8 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -18,9 +18,11 @@ import Obj import StructUtils import Template import ToTemplate +import TypeCandidate import TypeError import TypePredicates import Types +import RecType import TypesToC import Util import Validate @@ -30,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 = @@ -47,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 @@ -66,16 +68,25 @@ 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 - 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)) let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables - (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest - okInit <- binderForInit insidePath structTy initmembers - (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 + ptrinitmembers = map (recursiveMembersToPointers structTy) initmembers + 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 + (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 (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 pure (typeName, typeModuleXObj, deps) @@ -89,7 +100,11 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv = moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) insidePath = pathStrings ++ [typeName] 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)) + 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 @@ -119,6 +134,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) @@ -146,6 +167,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) @@ -459,6 +481,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 a2f2af381..9d116978d 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -15,8 +15,9 @@ 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) +import Data.Maybe (fromJust, fromMaybe, isJust) import Env import Info import qualified Map @@ -24,12 +25,14 @@ import qualified Meta import Obj import Path (takeFileName) import Project +import RecType import Scoring import qualified Set import Template import TypePredicates import Types import TypesToC +import TypeCandidate import Util addIndent :: Int -> String @@ -383,17 +386,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 _ = @@ -544,10 +559,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 @@ -813,44 +828,70 @@ 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@(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") + 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 -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. 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 + candidate = fromDeftype (getStructName structTy) vars empty empty mems + isRec = fromRight False (fmap isRecursive candidate) -- Note: the names of types are not namespaced visit = do - appendToSrc "typedef struct {\n" - mapM_ typedefCaseToMemberDecl rest - appendToSrc ("} " ++ tyToC structTy ++ ";\n") + -- forward declaration for recursive types. + when isRec $ + do appendToSrc ("// Recursive type \n") + appendToSrc ("struct " ++ tyToC structTy ++ " {\n") + when (not isRec) $ appendToSrc "typedef struct {\n" + mapM_ typedefCaseToMemberDecl pointerfix + appendToSrc "}" + unless isRec (appendToSrc (" " ++ tyToC structTy)) + appendToSrc ";\n" in if isTypeGeneric structTy then "" -- ("// " ++ show structTy ++ "\n") else emitterSrc (execState visit (EmitterState "")) 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 - 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) rest + mapM_ (emitSumtypeCase indent) pointerfix appendToSrc (addIndent indent ++ "char __dummy;\n") appendToSrc (addIndent indent ++ "} u;\n") appendToSrc (addIndent indent ++ "char _tag;\n") - appendToSrc ("} " ++ tyToC sumTy ++ ";\n") + appendToSrc "}" + unless isRec (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") @@ -858,7 +899,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") @@ -886,6 +927,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 @@ -1016,6 +1067,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 @@ -1025,7 +1078,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/Managed.hs b/src/Managed.hs index 0ef1ae52c..b059bcd86 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) 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 f789ac46a..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,8 +35,10 @@ import ToTemplate import TypeError import TypePredicates import Types +import TypeCandidate import Util import Web.Browser (openBrowser) +import RecType makeNullaryPrim :: SymPath -> NullaryPrimitiveCallback -> String -> String -> (String, Binder) makeNullaryPrim p = makePrim p . NullaryPrimitive @@ -646,11 +648,21 @@ 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 isRec + 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 new file mode 100644 index 000000000..bf32a88d3 --- /dev/null +++ b/src/RecType.hs @@ -0,0 +1,285 @@ +-- | Module RecType defines routines for working with recursive data types. +module RecType + ( + recursiveMembersToPointers, + isValueRecursive, + recursiveProductMakeBinder, + recursiveProductInitBinder, + recTemplateGetter, + okRecursive, + isRecursive, + ) +where + +import Obj +import Types +import TypePredicates +import TypeError +import TypeCandidate +import TypesToC +import StructUtils +import Template +import Util +import Data.Maybe (fromJust) +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 + +-- | 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 = + 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 -> Ty -> [InterfaceConstraint] +recInterfaceConstraints recTy t = + [ InterfaceConstraint "indirect" [(FuncTy [t] recTy StaticLifetimeTy)], + InterfaceConstraint "alloc" [(FuncTy [recTy] t StaticLifetimeTy)] + ] + +-------------------------------------------------------------------------------- +-- **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 +isValueRecursive _ _ = 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 = 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 + +-------------------------------------------------------------------------------- +-- Value 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" + +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 StackAlloc structTy membersXObjs) + ("creates a `" ++ show structTy ++ "`.") + where initArgListTypes :: [XObj] -> [Ty] + 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" + +-- | 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 + -- 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" + 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 = + 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 ++ ";" + +-- | 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" + 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/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/StructUtils.hs b/src/StructUtils.hs index feb62fc26..f488aa437 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,12 @@ 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;" + ] memberPrn typeEnv env (memberName, memberTy) = let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of @@ -52,6 +59,11 @@ 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);" + ] memberPrnSize typeEnv env (memberName, memberTy) = let (prefix, strFuncType) = memberStrCallingConvention "prn" typeEnv env memberTy in case nameOfPolymorphicFunction typeEnv env strFuncType "prn" of diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs index 43cf45c88..9d69a1cf3 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, @@ -11,31 +12,17 @@ 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) _ _]) _ _) = - 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 - in case sequence validated of - Left e -> - Left e - Right _ -> - Right $ - SumtypeCase - { caseName = name, - caseTys = okTys - } -toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) = - Right $ - SumtypeCase - { caseName = name, - 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 113b00970..c98690d36 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -17,7 +17,8 @@ import TypePredicates import Types import TypesToC import Util -import Validate (TypeVarRestriction (..)) +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,7 +46,7 @@ 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 = @@ -54,7 +55,11 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i insidePath = pathStrings ++ [typeName] in do let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables - cases <- toCases typeEnv env AllowOnlyNamesInScope typeVariables rest + ptrFix = map (recursiveMembersToPointers structTy) rest + candidate <- fromSumtype typeName typeVariables typeEnv env rest + okRecursive candidate + 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" @@ -88,19 +93,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 = @@ -138,13 +145,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 @@ -155,6 +164,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 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..0876561e0 --- /dev/null +++ b/src/TypeCandidate.hs @@ -0,0 +1,83 @@ +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' + | 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 :: [(String, [Ty])], + -- what sort of type variables are permitted. + restriction :: TypeVarRestriction, + -- what interfaces should types satisfy + interfaceConstraints :: [InterfaceConstraint], + 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 1dd46aa65..718f9baed 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -62,8 +62,12 @@ data TypeError | InconsistentKinds String [XObj] | FailedToAddLambdaStructToTyEnv SymPath XObj | FailedToInstantiateGenericType Ty + | InterfaceNotImplemented [String] + | InvalidProductField XObj 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 @@ -279,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/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..2de58b71b 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -28,6 +28,9 @@ module Types getNameFromStructName, getStructPath, promoteNumber, + tyMembers, + setMembers, + tyIsRecursive, ) where @@ -58,6 +61,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 @@ -81,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 @@ -88,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. @@ -195,6 +233,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 +287,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) @@ -275,11 +317,15 @@ 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 +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 +372,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 7b810a8ad..ffae81724 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -1,77 +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" #-} -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) - -- | 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 :: TypeCandidate -> Either TypeError () +validateMemberCases candidate = + validateMembers (candidate {restriction = AllowOnlyNamesInScope}) + +-- | 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 (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 (map interfaceName (interfaceConstraints candidate)) + where go ic = all (interfaceImplementedForTy (candidateTypeEnv candidate) (candidateEnv candidate) (interfaceName ic)) (types ic) + +-------------------------------------------------------------------------------- +-- 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 (map symbol dups)) where - visit (XObj (Arr membersXObjs) _ _) = - validateMembers AllowOnlyNamesInScope typeEnv globalEnv typeVariables membersXObjs - visit xobj = - Left (InvalidSumtypeCase xobj) + fields = fmap fst (typemembers candidate) + uniqueFields = nubBy (==) 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 (map reify (concat (map snd (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 + varsOnly = filter isTypeGeneric $ concat (map snd (typemembers candidate)) -okXObjForType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError () -okXObjForType typeVarRestriction typeEnv globalEnv typeVariables xobj = - case xobjToTy xobj of - Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables t xobj - Nothing -> Left (NotAType xobj) +-- | 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 = + 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 :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError () -canBeUsedAsMemberType 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 () @@ -86,7 +82,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 >> pure () -- Struct variables may appear as complete applications or individual -- components in the head of a definition; that is the forms: @@ -105,34 +101,41 @@ 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) + (RecTy _) -> pure () + _ -> Left (InvalidMemberType ty (reify ty)) 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 >> pure () - checkStruct (ConcreteNameTy path@(SymPath _ name)) vars = - case E.getTypeBinder typeEnv name <> 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 - Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars - _ -> Left (NotAmongRegisteredTypes ty xobj) + checkStruct (ConcreteNameTy (SymPath [] "Box")) [innerType] = + 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) () 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) () vars + Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> + 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 typeVarRestriction typeEnv globalEnv typeVariables v xobj - >> foldM (\_ typ -> canBeUsedAsMemberType 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 = @@ -142,7 +145,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj 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.