diff --git a/regression-tests/tests/foobar1.ssl b/regression-tests/tests/foobar1.ssl index 976ad627..f1a9a474 100644 --- a/regression-tests/tests/foobar1.ssl +++ b/regression-tests/tests/foobar1.ssl @@ -1,3 +1,6 @@ +type Pair2 a b + Pair2 a b + putip_ putc x = if x < 10 putc (x + 48) diff --git a/regression-tests/tests/par-ret-vals.out b/regression-tests/tests/par-ret-vals.out new file mode 100644 index 00000000..d463417e --- /dev/null +++ b/regression-tests/tests/par-ret-vals.out @@ -0,0 +1 @@ +C D diff --git a/regression-tests/tests/par-ret-vals.ssl b/regression-tests/tests/par-ret-vals.ssl new file mode 100644 index 00000000..15d9e0ba --- /dev/null +++ b/regression-tests/tests/par-ret-vals.ssl @@ -0,0 +1,21 @@ +// check that par return values work +// only currently support 2-tuple return values +add a b = a + b + +type Pair2 a b + Pair2 a b + +printCharTuple2 putc1 p1 = + match p1 + Pair2 x1 y1 = putc1 x1 + putc1 32 + putc1 y1 + +main cin cout = + let putc c = after 1, cout <- c + wait cout + let putnl _ = putc 10 + let z = par add 60 7 // intialize a par expression + add 60 8 + printCharTuple2 putc z + putnl 4 diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 7a555ab1..7712bea4 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -38,7 +38,9 @@ import qualified Language.C.Syntax as C import qualified Common.Compiler as Compiler import Common.Identifiers (fromId, fromString) -import Control.Monad (foldM, unless) +import Control.Monad (foldM, unless, when) + +-- import Control.Monad (foldM, unless) import Control.Monad.Except (MonadError (..)) import Control.Monad.State.Lazy ( MonadState, @@ -80,26 +82,26 @@ should be computed first, before this information is used to generate the act struct and enter definitions. -} data GenFnState = GenFnState - { fnName :: I.VarId - -- ^ Function name - , fnParams :: [I.Binder I.Type] - -- ^ Function parameters - , fnRetTy :: I.Type - -- ^ Function return type - , fnBody :: I.Expr I.Type - -- ^ Function body - , fnLocals :: M.Map I.VarId I.Type - -- ^ Function local variables - , fnVars :: M.Map I.VarId C.Exp - -- ^ How to resolve variables - , fnMaxWaits :: Int - -- ^ Number of triggers needed - , fnCases :: Int - -- ^ Yield point counter - , fnFresh :: Int - -- ^ Temporary variable name counter - , fnTypeInfo :: TypegenInfo - -- ^ (User-defined) type information + { -- | Function name + fnName :: I.VarId + , -- | Function parameters + fnParams :: [I.Binder I.Type] + , -- | Function return type + fnRetTy :: I.Type + , -- | Function body + fnBody :: I.Expr I.Type + , -- | Function local variables + fnLocals :: M.Map I.VarId I.Type + , -- | How to resolve variables + fnVars :: M.Map I.VarId C.Exp + , -- | Number of triggers needed + fnMaxWaits :: Int + , -- | Yield point counter + fnCases :: Int + , -- | Temporary variable name counter + fnFresh :: Int + , -- | (User-defined) type information + fnTypeInfo :: TypegenInfo } @@ -119,21 +121,21 @@ newtype GenFn a = GenFn (StateT GenFnState Compiler.Pass a) -- | Run a 'GenFn' computation on a procedure. -runGenFn - :: I.VarId - -- ^ Name of procedure - -> [I.Binder I.Type] - -- ^ Names and types of parameters to procedure - -> I.Expr I.Type - -- ^ Body of procedure - -> TypegenInfo - -- ^ Type information - -> [(I.VarId, I.Type)] - -- ^ Other global identifiers - -> GenFn a - -- ^ Translation monad to run - -> Compiler.Pass a - -- ^ Pass on errors to caller +runGenFn :: + -- | Name of procedure + I.VarId -> + -- | Names and types of parameters to procedure + [I.Binder I.Type] -> + -- | Body of procedure + I.Expr I.Type -> + -- | Type information + TypegenInfo -> + -- | Other global identifiers + [(I.VarId, I.Type)] -> + -- | Translation monad to run + GenFn a -> + -- | Pass on errors to caller + Compiler.Pass a runGenFn name params body typeInfo globals (GenFn tra) = evalStateT tra $ GenFnState @@ -299,10 +301,10 @@ genProgram p = do ++ cdefns ++ genInitProgram (I.programEntry p) where - genTop - :: TypegenInfo - -> (I.Binder I.Type, I.Expr I.Type) - -> Compiler.Pass ([C.Definition], [C.Definition]) + genTop :: + TypegenInfo -> + (I.Binder I.Type, I.Expr I.Type) -> + Compiler.Pass ([C.Definition], [C.Definition]) genTop tinfo (I.BindVar name _, l@I.Lambda{}) = runGenFn (fromId name) argIds body tinfo tops $ do (stepDecl, stepDefn) <- genStep @@ -696,11 +698,11 @@ genExpr (I.Match s as t) = do mkBlk :: CIdent -> [C.BlockItem] -> [C.BlockItem] mkBlk label blk = [citems|$id:label:;|] ++ blk ++ [citems|goto $id:joinLabel;|] - withAltScope - :: CIdent - -> I.Alt I.Type - -> GenFn [C.BlockItem] - -> GenFn (C.BlockItem, [C.BlockItem]) + withAltScope :: + CIdent -> + I.Alt I.Type -> + GenFn [C.BlockItem] -> + GenFn (C.BlockItem, [C.BlockItem]) withAltScope label a@(I.AltData dcon _ _) m = do destruct <- getsDCon dconDestruct dcon cas <- getsDCon dconCase dcon @@ -728,8 +730,8 @@ genExpr (I.Exception _ t) = do -- | Generate code for SSM primitive; see 'genExpr' for extended discussion. -genPrim - :: I.Primitive -> [I.Expr I.Type] -> I.Type -> GenFn (C.Exp, [C.BlockItem]) +genPrim :: + I.Primitive -> [I.Expr I.Type] -> I.Type -> GenFn (C.Exp, [C.BlockItem]) genPrim I.New [e] refType = do (val, stms) <- genExpr e tmp <- genTmp refType @@ -762,13 +764,13 @@ genPrim I.After [time, lhs, rhs] _ = do (timeVal, timeStms) <- genExpr time (lhsVal, lhsStms) <- genExpr lhs (rhsVal, rhsStms) <- genExpr rhs - let when = [cexp|$exp:now() + $exp:(unmarshal timeVal)|] + let when' = [cexp|$exp:now() + $exp:(unmarshal timeVal)|] laterBlock = [citems| $items:timeStms $items:lhsStms $items:rhsStms - $exp:(later lhsVal when rhsVal); + $exp:(later lhsVal when' rhsVal); $exp:(drop timeVal); $exp:(drop rhsVal); $exp:(drop lhsVal); @@ -792,9 +794,9 @@ genPrim I.Par procs _ = do -- implemented just yet. -- So, this is currently broken in that side effects inside the arguments -- of function calls will be evaluated sequentially, which is wrong. - apply - :: (I.Expr I.Type, (C.Exp, C.Exp)) - -> GenFn (C.Exp, [C.BlockItem], [C.BlockItem]) + apply :: + (I.Expr I.Type, (C.Exp, C.Exp)) -> + GenFn (C.Exp, [C.BlockItem], [C.BlockItem]) apply (I.App fn arg ty, (prio, depth)) = do (fnExp, fnStms) <- genExpr fn (argExp, argStms) <- genExpr arg @@ -809,12 +811,31 @@ genPrim I.Par procs _ = do return (ret, fnStms ++ argStms, appStms) apply (e, _) = do fail $ "Cannot compile par with non-application expression: " ++ show e + -- given a list of par return vals and their types, wrap the return vals in a tuple + genParRetVal :: [C.Exp] -> [I.Type] -> GenFn (C.Exp, [C.BlockItem]) + genParRetVal [] _ = fail "par should have 2 or more return values" + genParRetVal [_] _ = fail "par should have 2 or more return values" + genParRetVal rets@(ret0 : ret1 : _) retTys = do + -- TODO: given n ret vals, return an n-ary tuple + when (length rets /= length retTys) $ do fail "lists of return vals and types must be same length" + let dcon = I.tempTupleId (length rets) + let dty = I.tempTuple retTys + onHeap <- getsDCon dconOnHeap dcon + unless onHeap $ do + fail $ "Cannot handle packed fields yet, for: " ++ show dcon + construct <- getsDCon dconConstruct dcon + destruct <- getsDCon dconDestruct dcon + tmp <- genTmp dty + let alloc = [[citem|$exp:tmp = $exp:construct;|]] + initField y i = [citem|$exp:(destruct i tmp) = $exp:y;|] + initFields = zipWith initField [ret0, ret1] [0 ..] -- puts first two return vals in a 2-tuple for now + return (tmp, alloc ++ initFields) (_rets, befores, activates) <- unzip3 <$> mapM apply (zip procs parArgs) yield <- genYield - let parRetVal = unit -- TODO: return tuple of values + (parRetVal, tupleStms) <- genParRetVal _rets (I.extract <$> procs) return - (parRetVal, checkNewDepth ++ concat befores ++ concat activates ++ yield) + (parRetVal, checkNewDepth ++ concat befores ++ concat activates ++ yield ++ tupleStms) genPrim I.Wait vars _ = do (varVals, varStms) <- unzip <$> mapM genExpr vars maxWait $ length varVals @@ -866,8 +887,8 @@ genLiteralRaw I.LitEvent = [cexp|1|] -- | Generate C expression for SSM primitive operation. -genPrimOp - :: I.PrimOp -> [I.Expr I.Type] -> I.Type -> GenFn (C.Exp, [C.BlockItem]) +genPrimOp :: + I.PrimOp -> [I.Expr I.Type] -> I.Type -> GenFn (C.Exp, [C.BlockItem]) genPrimOp I.PrimAdd [lhs, rhs] _ = do ((lhsVal, rhsVal), stms) <- first (bimap unmarshal unmarshal) <$> genBinop lhs rhs @@ -946,8 +967,8 @@ genPrimOp _ _ _ = fail "Unsupported PrimOp or wrong number of arguments" -- | Helper for sequencing across binary operations. -genBinop - :: I.Expr I.Type -> I.Expr I.Type -> GenFn ((C.Exp, C.Exp), [C.BlockItem]) +genBinop :: + I.Expr I.Type -> I.Expr I.Type -> GenFn ((C.Exp, C.Exp), [C.BlockItem]) genBinop lhs rhs = do (lhsVal, lhsStms) <- genExpr lhs (rhsVal, rhsStms) <- genExpr rhs diff --git a/src/IR/Constraint/Canonical.hs b/src/IR/Constraint/Canonical.hs index 5c00003f..180695e2 100644 --- a/src/IR/Constraint/Canonical.hs +++ b/src/IR/Constraint/Canonical.hs @@ -43,7 +43,7 @@ import IR.Types.Type ( Type (..), builtinKinds, foldArrow, - tupleId, + tempTupleId, unAnnotations, unfoldArrow, ) @@ -141,7 +141,7 @@ pattern U8 = TCon "UInt8" [] -- | Construct a builtin tuple type out of a list of at least 2 types. tuple :: [Type] -> Type -tuple ts = TCon (tupleId $ length ts) ts +tuple ts = TCon (tempTupleId $ length ts) ts -- | ANNOTATION diff --git a/src/IR/Types/Type.hs b/src/IR/Types/Type.hs index 4512156c..60a40cae 100644 --- a/src/IR/Types/Type.hs +++ b/src/IR/Types/Type.hs @@ -256,6 +256,14 @@ isNum :: Type -> Bool isNum t = isInt t || isUInt t +{- | Construct a builtin tuple type out of a list of at least 2 types + +Uses tempTupleId instead of tupleId +-} +tempTuple :: [Type] -> Type +tempTuple ts = TCon (tempTupleId $ length ts) ts + + -- | Construct a builtin tuple type out of a list of at least 2 types. tuple :: [Type] -> Type tuple ts @@ -276,6 +284,10 @@ tupleId i | otherwise = error $ "Cannot create tuple of arity: " ++ show (toInteger i) +{- | Construct the type constructor of a builtin tuple of given arity (>= 2). + +Instead of using parentheses, use temporary data constructor name +-} tempTupleId :: (Integral i, Identifiable v) => i -> v tempTupleId i | i >= 2 = fromString $ "Pair" ++ show (toInteger i) diff --git a/test/semant/Tests/TypeInferSpec.hs b/test/semant/Tests/TypeInferSpec.hs index 486e138e..a42cd678 100644 --- a/test/semant/Tests/TypeInferSpec.hs +++ b/test/semant/Tests/TypeInferSpec.hs @@ -343,6 +343,8 @@ spec = do describe "larger, full-program test cases" $ do it "typechecks an unannotated, monomorphic program" $ do [here| + type Pair2 a b + Pair2 a b toggle(led : &Int) -> () = (led: &Int) <- (1 - deref (led: &Int): Int) slow(led : &Int) -> () = @@ -357,10 +359,12 @@ spec = do ((toggle: &Int -> ()) (led: &Int): ()) after 20 , (e2: &()) <- () wait (e2: &()) - main(led : &Int) -> ((), ()) = + main(led : &Int) -> (Pair2 () ()) = par ((slow: &Int -> ()) (led: &Int): ()) ((fast: &Int -> ()) (led: &Int): ()) |] `typeChecksAs` [here| + type Pair2 a b + Pair2 a b toggle(led) = led <- 1 - deref led slow(led) =