~jojo/Carth

e6b7ab0e3dbf3ca8af1eee50921673227a866ba1 — JoJo 2 years ago c9e4701
Impl genMatchPattern>PConstruction, genCtion
8 files changed, 85 insertions(+), 30 deletions(-)

M src/AnnotAst.hs
M src/Ast.hs
M src/Check.hs
M src/Codegen.hs
M src/Interp.hs
M src/Mono.hs
M src/MonoAst.hs
M src/Parse.hs
M src/AnnotAst.hs => src/AnnotAst.hs +1 -1
@@ 33,7 33,7 @@ data TypedVar = TypedVar String Type
type VariantIx = Word64

data Pat
    = PConstruction VariantIx [Pat]
    = PConstruction VariantIx [Type] [Pat]
    | PVar TypedVar
    deriving (Show, Eq)


M src/Ast.hs => src/Ast.hs +3 -3
@@ 90,7 90,7 @@ data Expr'
    | TypeAscr Expr Type
    | Match Expr (NonEmpty (Pat, Expr))
    | FunMatch (NonEmpty (Pat, Expr))
    | Constructor Id
    | Ctor Id
    deriving (Show, Eq)

type Expr = WithPos Expr'


@@ 161,7 161,7 @@ fvExpr = unpos >>> \case
    TypeAscr e _ -> freeVars e
    Match e cs -> fvMatch e (fromList1 cs)
    FunMatch cs -> fvCases (fromList1 cs)
    Constructor _ -> Set.empty
    Ctor _ -> Set.empty

bvPat :: Pat -> Set Id
bvPat = \case


@@ 257,7 257,7 @@ prettyExpr' d = \case
            (map1 (prettyBracketPair (d + 2)) cs)
        , ")"
        ]
    Constructor c -> pretty c
    Ctor c -> pretty c

prettyPat :: Pat -> String
prettyPat = \case

M src/Check.hs => src/Check.hs +12 -9
@@ 243,7 243,7 @@ infer = unpos >>> \case
        x <- freshVar
        let e = Fun (x, tpat) (Match (Var (TypedVar x tpat)) cases', tbody)
        pure (t, e)
    Ast.Constructor c -> inferExprConstructor c
    Ast.Ctor c -> inferExprConstructor c

-- TODO: Check that the patterns are exhaustive or variable/wildcard
-- | All the patterns must be of the same types, and all the bodies must be of


@@ 291,7 291,7 @@ inferPatConstruction pos c cArgs = do
    cArgsVars' <- nonconflictingPatVarDefs cArgsVars
    forM_ (zip3 cParams' cArgTs cArgs) $ \(cParamT, cArgT, cArg) ->
        unify (Expected cParamT) (Found (getPos cArg) cArgT)
    pure (t, PConstruction variantIx cArgs', cArgsVars')
    pure (t, PConstruction variantIx cArgTs cArgs', cArgsVars')

nonconflictingPatVarDefs :: [Map Id Scheme] -> Infer (Map Id Scheme)
nonconflictingPatVarDefs = flip foldM Map.empty $ \acc ks ->


@@ 303,12 303,13 @@ inferExprConstructor :: Id -> Infer (Type, Expr)
inferExprConstructor c = do
    (variantIx, tdefLhs, cParams) <- lookupEnvConstructor c
    (tdefInst, cParams') <- instantiateConstructorOfTypeDef tdefLhs cParams
    cParams'' <- mapM (\t -> freshVar >>= \x -> (x, t)) cParams'
    let cArgs = map (Var .* TypedVar) cParams''
    cParams'' <- mapM (\t -> fmap (, t) freshVar) cParams'
    let cArgs = map (Var . uncurry TypedVar) cParams''
        tInner = TConst tdefInst
    let t = foldr TFun tInner cParams'
    let e = foldr Fun (Ction (variantIx, tdefInst, cArgs), tInner) cParams''
    pure (t, e)
    pure $ foldr
        (\(p, tp) (tb, b) -> (TFun tp tb, Fun (p, tp) (b, tb)))
        (tInner, Ction (variantIx, tdefInst, cArgs))
        cParams''

instantiateConstructorOfTypeDef
    :: (String, [TVar]) -> [Type] -> Infer (TConst, [Type])


@@ 369,11 370,13 @@ substExpr s = \case
    Match e cs -> Match
        (substExpr s e)
        (map (\(p, b) -> (substPat s p, substExpr s b)) cs)
    Ctor c -> Ctor c
    Ction (i, (tx, tts), es) ->
        Ction (i, (tx, map (subst s) tts), map (substExpr s) es)

substPat :: Subst -> Pat -> Pat
substPat s = \case
    PConstruction c ps -> PConstruction c (map (substPat s) ps)
    PConstruction c ts ps ->
        PConstruction c (map (subst s) ts) (map (substPat s) ps)
    PVar (TypedVar x t) -> PVar (TypedVar x (subst s t))

subst :: Subst -> Type -> Type

M src/Codegen.hs => src/Codegen.hs +58 -8
@@ 131,10 131,14 @@ initSt = St
    , _registerCount = 0
    }

-- TODO: Will probably change type of variant-index. Update to reflect this.
-- | A data-type is a tagged union, and is represented in LLVM as a struct where
--   the first element is the variant-index as an i64, and the rest of the
--   elements are the field-types of the largest variant wrt allocation size.
genTypeDef :: (TConst, [[MonoAst.Type]]) -> Gen' Definition
genTypeDef (lhs, variants) = do
    let name = mkName (mangleTConst lhs)
    let ts = map (typeStruct . map toLlvmType) variants
    let ts = map toLlvmVariantType variants
    sizedTs <- mapM (\t -> fmap (, t) (sizeof t)) ts
    let (_, tmax) = maximum sizedTs
    pure (TypeDefinition name (Just tmax))


@@ 230,6 234,12 @@ genExpr = \case
    Match e cs -> genMatch e cs
    Ction c -> genCtion c

toLlvmDataType :: MonoAst.TConst -> Type
toLlvmDataType = typeNamed . mangleTConst

toLlvmVariantType :: [MonoAst.Type] -> Type
toLlvmVariantType = typeStruct . (i64 :) . map toLlvmType

-- | Convert to the LLVM representation of a type in an expression-context.
toLlvmType :: MonoAst.Type -> Type
toLlvmType = \case


@@ 239,7 249,7 @@ toLlvmType = \case
        TDouble -> double
        TChar -> i32
        TStr -> LLType.ptr i8
        TBool -> i1
        TBool -> typeBool
    TFun a r -> typeStruct
        [ LLType.ptr typeUnit
        , LLType.ptr (typeClosureFun (toLlvmType a) (toLlvmType r))


@@ 328,17 338,45 @@ genCase m nextL nextCaseL (p, b) = do
    pure (b', l)

genMatchPattern :: Name -> Operand -> Pat -> Gen [(TypedVar, Name)]
genMatchPattern _nextCaseL m = \case
    -- TODO: Change the fields of this constructor. Should be smth like index
    --       and type of variant.
    PConstruction _ _ -> nyi "genMatchPattern PConstruction"
genMatchPattern nextCaseL m = \case
    PConstruction i ts ps -> do
        let tvariant = toLlvmVariantType ts
        let i' = litU64' i
        j <- emitReg' "found_variant_ix" (extractvalue m [0])
        isMatch <- emitReg' "is_match" (icmp LLIntPred.EQ i' j)
        subpatsL <- newName "subpats"
        commitToNewBlock (condbr isMatch subpatsL nextCaseL) subpatsL
        let tgeneric = typeOf m
        pGeneric <- emitReg' "ction_ptr_generic" (alloca tgeneric)
        emit (store m pGeneric)
        p <- emitReg' "ction_ptr" (bitcast pGeneric (LLType.ptr tvariant))
        m' <- emitReg' "ction" (load p)
        genMatchPatterns nextCaseL m' ps
    PVar var@(TypedVar x t) -> do
        n <- newName x
        genVar n (toLlvmType t) m
        pure [(var, n)]

genMatchPatterns :: Name -> Operand -> [Pat] -> Gen [(TypedVar, Name)]
genMatchPatterns nextCaseL m ps =
    let
        f vsAcc (i, p) = do
            sm <- emitReg' "submatchee" (extractvalue m [i])
            vs <- genMatchPattern nextCaseL sm p
            pure (vs ++ vsAcc)
    in foldM f [] (zip [1 ..] ps)

genCtion :: MonoAst.Ction -> Gen Operand
genCtion (i, tdef, as) = nyi "genCtion"
genCtion (i, tdef, as) = do
    let i' = litU64' i
    as' <- mapM genExpr as
    s <- genStruct (i' : as')
    let t = typeOf s
    let tgeneric = toLlvmDataType tdef
    pGeneric <- emitReg' "ction_ptr_generic" (alloca tgeneric)
    p <- emitReg' "ction_ptr" (bitcast pGeneric (LLType.ptr t))
    emit (store s p)
    emitReg' "ction_generic" (load pGeneric)

withDefSigs :: [(TypedVar, Name)] -> Gen a -> Gen a
withDefSigs = augment localEnv . Map.fromList . map


@@ 465,7 503,7 @@ parameter :: Name -> Type -> LLGlob.Parameter
parameter p pt = LLGlob.Parameter pt p []

genSizeof :: Type -> Gen Operand
genSizeof = fmap (ConstantOperand . litI64 . fromIntegral) . sizeof'
genSizeof = fmap litU64' . sizeof'

sizeof' :: Type -> Gen Word64
sizeof' = lift . sizeof


@@ 621,6 659,15 @@ call f as = WithRetType
alloca :: Type -> FunInstruction
alloca t = WithRetType (Alloca t Nothing 0 []) t

icmp :: LLIntPred.IntegerPredicate -> Operand -> Operand -> FunInstruction
icmp p a b = WithRetType (ICmp p a b []) typeBool

litU64' :: Word64 -> Operand
litU64' = ConstantOperand . litU64

litU64 :: Word64 -> LLConst.Constant
litU64 = litI64 . fromIntegral

litI64 :: Int -> LLConst.Constant
litI64 = LLConst.Int 64 . toInteger



@@ 658,6 705,9 @@ typeNamed = NamedTypeReference . mkName
typeStruct :: [Type] -> Type
typeStruct ts = StructureType { isPacked = False, elementTypes = ts }

typeBool :: Type
typeBool = i1

typeUnit :: Type
typeUnit = StructureType { isPacked = False, elementTypes = [] }


M src/Interp.hs => src/Interp.hs +2 -2
@@ 86,11 86,11 @@ evalCases matchee = \case

matchPat :: Val -> Pat -> Eval (Maybe (Map TypedVar Val))
matchPat = curry $ \case
    (VConstruction c xs, PConstruction c' ps) | c == c' ->
    (VConstruction c xs, PConstruction c' _ ps) | c == c' ->
        zipWithM matchPat (reverse xs) ps <&> sequence <&> \case
            Just defss -> Just (Map.unions defss)
            Nothing -> Nothing
    (_, PConstruction _ _) -> pure Nothing
    (_, PConstruction _ _ _) -> pure Nothing
    (x, PVar v) -> pure (Just (Map.singleton v x))

lookupEnv :: (String, Type) -> Eval Val

M src/Mono.hs => src/Mono.hs +3 -2
@@ 104,9 104,10 @@ monoCase (p, e) = do

monoPat :: An.Pat -> Mono (Pat, Set String)
monoPat = \case
    An.PConstruction c ps -> do
    An.PConstruction c ts ps -> do
        ts' <- mapM monotype ts
        (ps', bvs) <- fmap unzip (mapM monoPat ps)
        pure (PConstruction c ps', Set.unions bvs)
        pure (PConstruction c ts' ps', Set.unions bvs)
    An.PVar (An.TypedVar x t) ->
        fmap (\t' -> (PVar (TypedVar x t'), Set.singleton x)) (monotype t)


M src/MonoAst.hs => src/MonoAst.hs +5 -4
@@ 40,8 40,10 @@ data Type
data TypedVar = TypedVar String Type
    deriving (Show, Eq, Ord)

type VariantTypes = [Type]

data Pat
    = PConstruction VariantIx [Pat]
    = PConstruction VariantIx VariantTypes [Pat]
    | PVar TypedVar
    deriving (Show, Eq)



@@ 62,8 64,7 @@ data Expr
newtype Defs = Defs (Map TypedVar Expr)
    deriving (Show)

type Variant = [Type]
type TypeDefs = [(TConst, [Variant])]
type TypeDefs = [(TConst, [VariantTypes])]

data Program = Program Expr Defs TypeDefs
    deriving (Show)


@@ 89,7 90,7 @@ fvExpr = \case

bvPat :: Pat -> Set TypedVar
bvPat = \case
    PConstruction _ ps -> Set.unions (map bvPat ps)
    PConstruction _ _ ps -> Set.unions (map bvPat ps)
    PVar x -> Set.singleton x

mainType :: Type

M src/Parse.hs => src/Parse.hs +1 -1
@@ 139,7 139,7 @@ ns_expr = withPos
        (choice [funMatch, match, if', fun, let', typeAscr, app])

eConstructor :: Parser Expr'
eConstructor = fmap Constructor ns_big'
eConstructor = fmap Ctor ns_big'

var :: Parser Expr'
var = fmap Var ns_small'