diff --git a/src/Deftype.hs b/src/Deftype.hs index ac350f67..1bbba0f7 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -77,23 +77,45 @@ templatesForMembers _ _ _ _ _ = error "Shouldn't reach this case (invalid type d -- | Generate the templates for a single member in a deftype declaration. templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])] templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy typeName) _) (nameXObj, typeXObj) = - let Just t = xobjToTy typeXObj - memberName = getName nameXObj - in [instanceBinderWithDeps (SymPath insidePath memberName) (FuncTy [RefTy p (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy) (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.") - , if isTypeGeneric t - then (templateGenericSetter insidePath p t memberName, []) - else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) (FuncTy [p, t] p StaticLifetimeTy) (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.") - , if isTypeGeneric t - then (templateGenericMutatingSetter insidePath p t memberName, []) - else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place.") - ,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName)) - (FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy) - (templateUpdater (mangle memberName)) - ("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.") - ] + case t of + -- Unit member types are special since we do not represent them in emitted c. + -- Instead, members of type Unit are executed for their side effects and silently omitted + -- from the produced C structs. + UnitTy -> + binders (FuncTy [RefTy p (VarTy "q")] UnitTy StaticLifetimeTy) + (FuncTy [p, t] p StaticLifetimeTy) + (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy) + (FuncTy [p, RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy) + _ -> + 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) + where Just t = xobjToTy typeXObj + memberName = getName nameXObj + binders getterSig setterSig mutatorSig updaterSig = + [instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.") + , if isTypeGeneric t + then (templateGenericSetter insidePath p t memberName, []) + else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`.") + , if isTypeGeneric t + then (templateGenericMutatingSetter insidePath p t memberName, []) + else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place.") + ,instanceBinderWithDeps (SymPath insidePath ("update-" ++ memberName)) + updaterSig + (templateUpdater (mangle memberName) t) + ("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.") + ] -- | The template for getters of a deftype. templateGetter :: String -> Ty -> Template +templateGetter member UnitTy = + Template + (FuncTy [RefTy (VarTy "p") (VarTy "q")] UnitTy StaticLifetimeTy) + (const (toTemplate "void $NAME($(Ref p) p)")) + -- Execution of the action passed as an argument is handled in Emit.hs. + (const $ toTemplate ("$DECL { return; }\n")) + (const []) templateGetter member memberTy = Template (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy) @@ -108,6 +130,13 @@ templateGetter member memberTy = -- | The template for setters of a concrete deftype. templateSetter :: TypeEnv -> Env -> String -> Ty -> Template +templateSetter typeEnv env memberName UnitTy = + Template + (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy) + (const (toTemplate "$p $NAME($p p)")) + -- Execution of the action passed as an argument is handled in Emit.hs. + (const (toTemplate "$DECL { return p; }\n")) + (const []) templateSetter typeEnv env memberName memberTy = let callToDelete = memberDeletion typeEnv env (memberName, memberTy) in @@ -149,6 +178,13 @@ templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typ -- | The template for mutating setters of a deftype. templateMutatingSetter :: TypeEnv -> Env -> String -> Ty -> Template +templateMutatingSetter typeEnv env memberName UnitTy = + Template + (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy) + (const (toTemplate "void $NAME($p* pRef)")) + -- Execution of the action passed as an argument is handled in Emit.hs. + (const (toTemplate "$DECL { return; }\n")) + (const []) templateMutatingSetter typeEnv env memberName memberTy = let callToDelete = memberRefDeletion typeEnv env (memberName, memberTy) in Template @@ -185,8 +221,16 @@ templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNa -- | The template for updater functions of a deftype. -- | (allows changing a variable by passing an transformation function). -templateUpdater :: String -> Template -templateUpdater member = +templateUpdater :: String -> Ty -> Template +templateUpdater member UnitTy = + Template + (FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) + (const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t) + -- Execution of the action passed as an argument is handled in Emit.hs. + (const (toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n"))) + (\(FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _) -> + [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]) +templateUpdater member _ = Template (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy) (const (toTemplate "$p $NAME($p p, Lambda *updater)")) -- "Lambda" used to be: $(Fn [t] t) @@ -211,7 +255,8 @@ binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj ( -- | Generate a list of types from a deftype declaration. initArgListTypes :: [XObj] -> [Ty] -initArgListTypes xobjs = map (\(_, x) -> fromJust (xobjToTy x)) (pairwise xobjs) +initArgListTypes xobjs = + (map (fromJust . xobjToTy . snd) (pairwise xobjs)) -- | The template for the 'init' and 'new' functions for a concrete deftype. concreteInit :: AllocationMode -> Ty -> [XObj] -> Template @@ -222,9 +267,13 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) let mappings = unifySignatures originalStructTy concreteStructTy correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs memberPairs = memberXObjsToPairs correctedMembers - in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg memberPairs) ++ ")")) - (const (tokensForInit allocationMode typeName membersXObjs)) + in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")")) + (\(FuncTy _ concreteStructTy _) -> + let mappings = unifySignatures originalStructTy concreteStructTy + correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs + in (tokensForInit allocationMode typeName correctedMembers)) (\FuncTy{} -> []) + where unitless = filter (notUnit . snd) -- | The template for the 'init' and 'new' functions for a generic deftype. genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder) @@ -241,8 +290,11 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT let mappings = unifySignatures originalStructTy concreteStructTy correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs memberPairs = memberXObjsToPairs correctedMembers - in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg memberPairs) ++ ")")) - (const (tokensForInit allocationMode typeName membersXObjs)) + in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (filter (notUnit . snd) memberPairs)) ++ ")")) + (\(FuncTy _ concreteStructTy _) -> + let mappings = unifySignatures originalStructTy concreteStructTy + correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs + in (tokensForInit allocationMode typeName correctedMembers)) (\(FuncTy _ concreteStructTy _) -> case concretizeType typeEnv concreteStructTy of Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.") @@ -253,14 +305,21 @@ tokensForInit :: AllocationMode -> String -> [XObj] -> [Token] tokensForInit allocationMode typeName membersXObjs = toTemplate $ unlines [ "$DECL {" , case allocationMode of - StackAlloc -> " $p instance;" + 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 = {0};" + _ -> " $p instance;" HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));" , assignments membersXObjs , " return instance;" , "}"] - where assignments [] = " instance.__dummy = 0;" - assignments xobjs = joinLines $ memberAssignment allocationMode . fst <$> memberXObjsToPairs xobjs - + where assignments [] = " instance = {0};" + assignments xobjs = go $ unitless + where go [] = "" + go xobjs = joinLines $ memberAssignment allocationMode . fst <$> xobjs + unitless = filter (notUnit . snd) (memberXObjsToPairs membersXObjs) -- | Creates the C code for an arg to the init function. -- | i.e. "(deftype A [x Int])" will generate "int x" which diff --git a/src/Emit.hs b/src/Emit.hs index d485f1eb..bc0d590a 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -13,7 +13,7 @@ import Control.Monad.State import Control.Monad (when, zipWithM_) import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, fromJust) import Debug.Trace import Data.Char (ord) @@ -316,6 +316,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo -- This requires a bunch of extra machinery though, so this will do for now... [var ++ periodOrArrow ++ "_tag == " ++ tagName caseTy (removeSuffix caseName)] ++ concat (zipWith (\c i -> tagCondition (var ++ periodOrArrow ++ "u." ++ removeSuffix caseName ++ ".member" ++ show i) "." (forceTy c) c) caseMatchers [0..]) + where notUnitX (XObj _ _ (Just UnitTy)) = False + notUnitX _ = True tagCondition _ _ _ x = [] --error ("tagCondition fell through: " ++ show x) @@ -354,7 +356,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo MatchRef -> ("->", "&") appendToSrc ("if(" ++ joinWith " && " (tagCondition exprVar (fst refModifications) (removeOuterRefTyIfMatchRef exprTy) caseLhs) ++ ") {\n") appendToSrc (addIndent indent' ++ tyToCLambdaFix exprTy ++ " " ++ tempVarToAvoidClash ++ " = " ++ exprVar ++ ";\n") - zipWithM_ (emitCaseMatcher refModifications (removeSuffix caseName)) caseMatchers [0..] + zipWithM_ (emitCaseMatcher refModifications (removeSuffix caseName)) (filter (notUnit . forceTy) caseMatchers) [0..] appendToSrc (addIndent indent' ++ "// Case expr:\n") emitCaseEnd caseLhsInfo caseExpr emitCase exprVar isFirst (XObj (Sym firstPath _) caseLhsInfo _, caseExpr) = @@ -604,11 +606,15 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo createArgList :: Int -> Bool -> [XObj] -> State EmitterState String createArgList indent unwrapLambdas args = - do argStrings <- mapM (visit indent) args + do argStrings <- mapM (visit indent) (filter (notUnit . forceTy) args) let argTypes = map forceTy args - return $ intercalate ", " $ if unwrapLambdas - then zipWith unwrapLambda argStrings argTypes - else argStrings + unitless = filter notUnit argTypes + -- Run side effects + sideEffects = mapM (visit indent) (filter (not . notUnit . forceTy) args) >>= return . intercalate ";\n" + unwrapped = joinWithComma $ if unwrapLambdas + then zipWith unwrapLambda argStrings unitless + else argStrings + sideEffects >> return unwrapped unwrapLambda :: String -> Ty -> String unwrapLambda variableName ty = @@ -716,7 +722,7 @@ defStructToDeclaration structTy@(StructTy typeName typeVariables) path 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) (pairwise members) + typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl indent) (filter (notUnit . fromJust . xobjToTy . snd) (pairwise members)) typedefCaseToMemberDecl _ = error "Invalid case in typedef." -- Note: the names of types are not namespaced @@ -746,7 +752,7 @@ defSumtypeToDeclaration sumTy@(StructTy typeName typeVariables) path rest = appendToSrc (addIndent indent ++ "// " ++ caseName ++ "\n") emitSumtypeCase indent xobj@(XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr memberTys) _ _]) _ _) = do appendToSrc (addIndent indent ++ "struct {\n") - let members = zipWith (\anonName tyXObj -> (anonName, tyXObj)) anonMemberSymbols memberTys + let members = zipWith (\anonName tyXObj -> (anonName, tyXObj)) anonMemberSymbols (filter (notUnit . fromJust . xobjToTy) memberTys) mapM_ (memberToDecl (indent + indentAmount)) members appendToSrc (addIndent indent ++ "} " ++ caseName ++ ";\n") emitSumtypeCase indent xobj@(XObj (Sym (SymPath [] caseName) _) _ _) = @@ -766,8 +772,10 @@ defaliasToDeclaration :: Ty -> SymPath -> String defaliasToDeclaration t path = case t of (FuncTy argTys retTy _) -> "typedef " ++ tyToCLambdaFix retTy ++ "(*" ++ pathToC path ++ ")(" ++ - intercalate ", " (map tyToCLambdaFix argTys) ++ ");\n" + intercalate ", " (map fixer argTys) ++ ");\n" _ -> "typedef " ++ tyToC t ++ " " ++ pathToC path ++ ";\n" + where fixer UnitTy = "void*" + fixer x = tyToCLambdaFix x toDeclaration :: Binder -> String toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ t)) = @@ -811,12 +819,12 @@ toDeclaration (Binder meta xobj@(XObj (Lst xobjs) _ t)) = toDeclaration _ = error "Missing case." paramListToC :: [XObj] -> String -paramListToC xobjs = intercalate ", " (map getParam (filter notUnit xobjs)) +paramListToC xobjs = if null $ joinWithComma (map getParam xobjs) + then "" + else joinWithComma (map getParam (filter (notUnit . forceTy) xobjs)) where getParam :: XObj -> String getParam (XObj (Sym (SymPath _ name) _) _ (Just t)) = tyToCLambdaFix t ++ " " ++ mangle name getParam invalid = error (show (InvalidParameter invalid)) - notUnit (XObj _ _ (Just UnitTy)) = False - notUnit _ = True projectIncludesToC :: Project -> String projectIncludesToC proj = intercalate "\n" (map includerToC includes) ++ "\n\n" diff --git a/src/Obj.hs b/src/Obj.hs index ff847870..e03ae16a 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -582,6 +582,7 @@ incrementEnvNestLevel env = let current = envFunctionNestingLevel env -- | Converts an S-expression to one of the Carp types. xobjToTy :: XObj -> Maybe Ty +xobjToTy (XObj (Sym (SymPath _ "Unit") _) _ _) = Just UnitTy xobjToTy (XObj (Sym (SymPath _ "Int") _) _ _) = Just IntTy xobjToTy (XObj (Sym (SymPath _ "Float") _) _ _) = Just FloatTy xobjToTy (XObj (Sym (SymPath _ "Double") _) _ _) = Just DoubleTy diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 5040ea67..dc4c59cc 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -73,7 +73,7 @@ concreteCaseInit allocationMode insidePath structTy sumtypeCase = (\(FuncTy _ concreteStructTy _) -> let mappings = unifySignatures structTy concreteStructTy correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) - in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames correctedTys) ++ ")")) + in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (filter notUnit correctedTys)) ++ ")")) (const (tokensForCaseInit allocationMode structTy sumtypeCase)) (\FuncTy{} -> []) @@ -90,26 +90,28 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase = (\(FuncTy _ concreteStructTy _) -> let mappings = unifySignatures originalStructTy concreteStructTy correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) - in toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames correctedTys) ++ ")") + in toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (filter notUnit correctedTys)) ++ ")") (\(FuncTy _ concreteStructTy _) -> - tokensForCaseInit allocationMode concreteStructTy sumtypeCase) + let mappings = unifySignatures originalStructTy concreteStructTy + correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase) + in tokensForCaseInit allocationMode concreteStructTy (sumtypeCase {caseTys = correctedTys})) (\(FuncTy _ concreteStructTy _) -> case concretizeType typeEnv concreteStructTy of Left err -> error (show err ++ ". This error should not crash the compiler - change return type to Either here.") Right ok -> ok) - tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token] tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy typeName) typeVariables) sumtypeCase = toTemplate $ unlines [ "$DECL {" , case allocationMode of StackAlloc -> " $p instance;" HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));" - , joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> zip anonMemberNames (caseTys sumtypeCase) + , joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless , " instance._tag = " ++ tagName sumTy correctedName ++ ";" , " return instance;" , "}"] where correctedName = caseName sumtypeCase + unitless = zip anonMemberNames $ filter notUnit (caseTys sumtypeCase) caseMemberAssignment :: AllocationMode -> String -> String -> String caseMemberAssignment allocationMode caseName memberName = @@ -194,9 +196,10 @@ tokensForStr typeEnv env typeName cases concreteStructTy = , " return buffer;" , "}"] +namesFromCase :: SumtypeCase -> Ty -> (String, [Ty], String) namesFromCase theCase concreteStructTy = let name = caseName theCase - in (name, caseTys theCase, tagName concreteStructTy name) + in (name, caseTys theCase {caseTys = (filter notUnit (caseTys theCase))}, tagName concreteStructTy name) strCase :: TypeEnv -> Env -> Ty -> SumtypeCase -> String strCase typeEnv env concreteStructTy@(StructTy _ typeVariables) theCase = diff --git a/src/Types.hs b/src/Types.hs index 94aa73d6..938d3f94 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -20,6 +20,7 @@ module Types ( TypeMappings , consPath , Kind , tyToKind + , notUnit ) where import qualified Data.Map as Map @@ -260,3 +261,7 @@ isFullyGenericType _ = False -- | The type of environments sent to Lambdas (used in emitted C code) lambdaEnvTy :: Ty lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") [] + +notUnit :: Ty -> Bool +notUnit UnitTy = False +notUnit _ = True diff --git a/src/Validate.hs b/src/Validate.hs index 746c21c0..85072354 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -35,6 +35,7 @@ okXObjForType typeEnv typeVariables xobj = canBeUsedAsMemberType :: TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError () canBeUsedAsMemberType typeEnv typeVariables t xobj = case t of + UnitTy -> return () IntTy -> return () FloatTy -> return () DoubleTy -> return ()