~jojo/Carth

e99a9cdb99eca78bc261ec274afd46caec806fd5 — JoJo 1 year, 11 months ago 999ddcb
Impl pattern matching w decision trees & check for redundancy

TODO: Check for exhaustiveness. TODO: Use the stratergy in that paper
on "good decision trees" for picking columns instead of just building
the tree left-to-right.

Sorry for the big commit. This wasn't the easiest thing to
implement. Took a while to understand how the whole thing would work,
and had lots of small problems along the way. However, I'm mostly
satistied with the result.
M TODO.org => TODO.org +7 -2
@@ 40,11 40,14 @@ the fix etc:
    Some details were not implemented in this step. Exhaustive pattern
    checking, and handling of recursive datatypes.

** TODO Check patterns for exhaustiveness and redundancy
** DONE Implement pattern matching w decision trees
   Slower to compile, faster to execute
** DONE Check patterns for redundancy
** TODO Check patterns for exhaustiveness
   For a datatype ~(type Foo Bar Baz)~, following are some examples of
   pattern matches and expected results:

   - ~(match x [Bar y] [Baz z]~ :: is exhaustive and non-reduntant, and should pass.
   - ~(match x [Bar y] [Baz z])~ :: is exhaustive and non-reduntant, and should pass.
   - ~(match x [Bar y] [xx z])~ :: is exhaustive and non-redundant, and should pass.
   - ~(match x [Bar y])~ :: is inexhaustive and should produce an error.
   - ~(match x [xx z] [Bar y])~ :: is exhaustive but redundant, and should produce an error or warning.


@@ 79,6 82,8 @@ the fix etc:
             point to make `Foo` representable
   #+END_EXAMPLE

** NEXT Uninhabited types
   Definition and pattern-matching of.
* NEXT Typeclasses
** Agda style classes w implicit args
   In Haskell, you can only have a single instance of a specific

M src/AnnotAst.hs => src/AnnotAst.hs +8 -7
@@ 10,10 10,10 @@ module AnnotAst
    , Type(..)
    , Scheme(..)
    , TypedVar(..)
    , Const(..)
    , VariantIx
    , Pat(..)
    , DecisionTree(..)
    , Ction
    , Const(..)
    , Expr(..)
    , Defs(..)
    , TypeDefs


@@ 32,10 32,11 @@ data TypedVar = TypedVar String Type

type VariantIx = Word64

data Pat
    = PConstruction VariantIx [Type] [Pat]
    | PVar TypedVar
    deriving (Show, Eq)
data DecisionTree
    = DecisionTree (Map VariantIx ([Type], DecisionTree))
                   (Maybe (TypedVar, DecisionTree))
    | DecisionLeaf Expr
    deriving (Show)

type Ction = (VariantIx, (String, [Type]), [Expr])



@@ 46,7 47,7 @@ data Expr
    | If Expr Expr Expr
    | Fun (String, Type) (Expr, Type)
    | Let Defs Expr
    | Match Expr [(Pat, Expr)]
    | Match Expr DecisionTree Type
    | Ction Ction
    deriving (Show)


M src/Ast.hs => src/Ast.hs +6 -3
@@ 119,9 119,6 @@ instance FreeVars Def Id where
instance FreeVars Expr Id where
    freeVars = fvExpr

instance Pattern Pat Id where
    patternBoundVars = bvPat

instance HasPos Pat where
    getPos = \case
        PConstruction p _ _ -> p


@@ 163,6 160,12 @@ fvExpr = unpos >>> \case
    FunMatch cs -> fvCases (fromList1 cs)
    Ctor _ -> Set.empty

fvMatch :: Expr -> [(Pat, Expr)] -> Set Id
fvMatch e cs = Set.union (freeVars e) (fvCases cs)

fvCases :: [(Pat, Expr)] -> Set Id
fvCases = Set.unions . map (\(p, e) -> Set.difference (freeVars e) (bvPat p))

bvPat :: Pat -> Set Id
bvPat = \case
    PConstruction _ _ ps -> Set.unions (map bvPat ps)

M src/Check.hs => src/Check.hs +114 -70
@@ 11,16 11,19 @@ import Control.Monad.State.Strict
import Control.Arrow ((>>>))
import Data.Either.Combinators
import Data.Bifunctor
import Data.Foldable
import Data.Graph (SCC(..), flattenSCC, stronglyConnComp)
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Composition
import qualified Data.Set as Set
import Data.Set (Set)

import Misc
import SrcPos
import FreeVars
import Subst
import NonEmpty
import qualified Ast
import Ast (Id, idstr, scmBody)


@@ 33,12 36,10 @@ data Env = Env
    --   constructs, the signature/left-hand-side of the type definition, and
    --   the types of its parameters
    , _envCtors :: Map String (VariantIx, (String, [TVar]), [Type])
    , _envTypeDefs :: Map String ([TVar], [[Type]])
    }
makeLenses ''Env

-- | Map of substitutions from type-variables to more specific types
type Subst = Map TVar Type

data St = St
    { _tvCount :: Int
    , _substs :: Subst


@@ 49,6 50,7 @@ makeLenses ''St
-- | Type checker monad
type Infer a = ReaderT Env (StateT St (Except TypeErr)) a


typecheck :: Ast.Program -> Either TypeErr Program
typecheck = runInfer . inferProgram



@@ 60,7 62,11 @@ runInfer' :: Infer a -> Either TypeErr (a, St)
runInfer' = runExcept . flip runStateT initSt . flip runReaderT initEnv

initEnv :: Env
initEnv = Env { _envDefs = builtinSchemes, _envCtors = Map.empty }
initEnv = Env
    { _envDefs = builtinSchemes
    , _envCtors = Map.empty
    , _envTypeDefs = Map.empty
    }

builtinSchemes :: Map String Scheme
builtinSchemes = Map.fromList


@@ 99,7 105,8 @@ inferProgram (Ast.Program defs tdefs) = do
        pure
        (lookup "main" (map (first unpos) defs))
    (tdefs', ctors) <- checkTypeDefs tdefs
    Defs defs' <- augment envCtors ctors (inferDefs defs)
    Defs defs' <-
        augment envTypeDefs tdefs' $ augment envCtors ctors $ inferDefs defs
    let (Forall _ mainT, main) = fromJust (Map.lookup "main" defs')
    let expectedMainType = TFun (TPrim TUnit) (TPrim TUnit)
    unify (Expected expectedMainType) (Found mainPos mainT)


@@ 227,22 234,29 @@ infer = unpos >>> \case
    Ast.Match matchee cases -> do
        (tmatchee, matchee') <- infer matchee
        (tbody, cases') <- inferCases (Expected tmatchee) cases
        pure (tbody, Match matchee' cases')
        dt <- toDecisionTree tmatchee cases'
        pure (tbody, Match matchee' dt tbody)
    Ast.FunMatch cases -> do
        tpat <- fresh
        (tbody, cases') <- inferCases (Expected tpat) cases
        dt <- toDecisionTree tpat cases'
        let t = TFun tpat tbody
        x <- freshVar
        let e = Fun (x, tpat) (Match (Var (TypedVar x tpat)) cases', tbody)
        let e = Fun (x, tpat) (Match (Var (TypedVar x tpat)) dt tbody, tbody)
        pure (t, e)
    Ast.Ctor c -> inferExprConstructor c

data Pat
    = PConstruction VariantIx [Type] [Pat]
    | PVar String
    deriving (Show)

-- | All the patterns must be of the same types, and all the bodies must be of
--   the same type.
inferCases
    :: ExpectedType -- Type of matchee. Expected type of pattern.
    -> NonEmpty (Ast.Pat, Ast.Expr)
    -> Infer (Type, [(Pat, Expr)])
    -> Infer (Type, [(SrcPos, Pat, Expr)])
inferCases tmatchee cases = do
    (tpats, tbodies, cases') <- fmap unzip3 (mapM inferCase (fromList1 cases))
    forM_ tpats (unify tmatchee)


@@ 250,12 264,14 @@ inferCases tmatchee cases = do
    forM_ tbodies (unify (Expected tbody))
    pure (tbody, cases')

inferCase :: (Ast.Pat, Ast.Expr) -> Infer (FoundType, FoundType, (Pat, Expr))
inferCase
    :: (Ast.Pat, Ast.Expr) -> Infer (FoundType, FoundType, (SrcPos, Pat, Expr))
inferCase (p, b) = do
    (tp, p', pvs) <- inferPat p
    let pvs' = Map.mapKeys Ast.idstr pvs
    (tb, b') <- withLocals' pvs' (infer b)
    pure (Found (getPos p) tp, Found (getPos b) tb, (p', b'))
    let ppos = getPos p
    pure (Found ppos tp, Found (getPos b) tb, (ppos, p', b'))

inferPat :: Ast.Pat -> Infer (Type, Pat, Map Id Scheme)
inferPat = \case


@@ 263,11 279,7 @@ inferPat = \case
    Ast.PVar x -> do
        tv <- fresh'
        let tv' = TVar tv
        pure
            ( tv'
            , PVar (TypedVar (idstr x) tv')
            , Map.singleton x (Forall Set.empty tv')
            )
        pure (tv', PVar (idstr x), Map.singleton x (Forall Set.empty tv'))

inferPatConstruction
    :: SrcPos -> Id -> [Ast.Pat] -> Infer (Type, Pat, Map Id Scheme)


@@ 290,6 302,90 @@ nonconflictingPatVarDefs = flip foldM Map.empty $ \acc ks ->
        Just (WithPos pos v) -> throwError (ConflictingPatVarDefs pos v)
        Nothing -> pure (Map.union acc ks)

-- TODO: Check for exhaustiveness
-- | Build decision tree that matches out -> in, left -> right
--
--   For each variant/constructor, there is a node in the decision tree. When
--   picking a ctor in a column to create a sub-tree, remove all rows in that
--   column not beginning with that ctor, then splice the members of the variant
--   into the matrix.
toDecisionTree :: Type -> [(SrcPos, Pat, Expr)] -> Infer DecisionTree
toDecisionTree tpat cs =
    toDecisionTreeRows tpat [] (map (\(pos, p, e) -> (pos, p, [], e)) cs)

toDecisionTreeRows
    :: Type -> [Type] -> [(SrcPos, Pat, [Pat], Expr)] -> Infer DecisionTree
toDecisionTreeRows tpat tpats cases = do
    varName <- freshVar
    (ctorCases, varCases) <- foldlM
        (toDecisionTreeRow tpats varName)
        (Map.empty, [])
        cases
    buildDecisionTree ctorCases (TypedVar varName tpat) (tpats, varCases)

toDecisionTreeRow
    :: [Type]
    -> String
    -> ( Map VariantIx ([Type], [(SrcPos, [Pat], Expr)])
       , [(SrcPos, [Pat], Expr)]
       )
    -> (SrcPos, Pat, [Pat], Expr)
    -> Infer
           ( Map VariantIx ([Type], [(SrcPos, [Pat], Expr)])
           , [(SrcPos, [Pat], Expr)]
           )
toDecisionTreeRow ts varName (ctorCases, varCases) (pos, col, cols, body) =
    case col of
        PConstruction ctor cts ps ->
            if isRedundant ps (map (\(_, x, _) -> x) varCases)
                then throwError (RedundantCase pos)
                else
                    let
                        row' = (pos, ps ++ cols, body)
                        ts' = cts ++ ts
                        ctorCases' =
                            insertOrPrefix ctor (ts', [row']) ctorCases
                    in pure (ctorCases', varCases)
        PVar x ->
            let
                body' = substVExpr (x, varName) body
                varCases' = (pos, cols, body') : varCases
            in pure (ctorCases, varCases')

isRedundant :: [Pat] -> [[Pat]] -> Bool
isRedundant ps = any (isRedundant' ps)

isRedundant' :: [Pat] -> [Pat] -> Bool
isRedundant' = all isRedundant'' .* zip

isRedundant'' :: (Pat, Pat) -> Bool
isRedundant'' = \case
    (PConstruction _ _ ps, PConstruction _ _ qs) -> isRedundant' ps qs
    (PConstruction _ _ _, PVar _) -> False
    (PVar _, _) -> True

buildDecisionTree
    :: Map VariantIx ([Type], [(SrcPos, [Pat], Expr)])
    -> TypedVar
    -> ([Type], [(SrcPos, [Pat], Expr)])
    -> Infer DecisionTree
buildDecisionTree ctorCases varLhs varCases@(_, varCases') = do
    ctorCases' <- forM ctorCases
        $ \cs@(ts, _) -> fmap (ts, ) (toDecisionTreeRows' cs)
    varDecisionTree <- if null varCases'
        then pure Nothing
        else fmap (Just . (varLhs, )) (toDecisionTreeRows' varCases)
    pure (DecisionTree ctorCases' varDecisionTree)

toDecisionTreeRows' :: ([Type], [(SrcPos, [Pat], Expr)]) -> Infer DecisionTree
toDecisionTreeRows' = \case
    ([], [(_, [], body)]) -> pure (DecisionLeaf body)
    ([], (pos, _, _) : _) -> throwError (RedundantCase pos)
    (t : ts, cs) -> toDecisionTreeRows t ts $ flip map cs $ \case
        (_, [], _) -> ice "ps empty in toDecisionTreeRows'"
        (pos, p : ps, b) -> (pos, p, ps, b)
    x -> ice $ "unexpected pattern in toDecisionTreeRows': " ++ show x

inferExprConstructor :: Id -> Infer (Type, Expr)
inferExprConstructor c = do
    (variantIx, tdefLhs, cParams) <- lookupEnvConstructor c


@@ 313,18 409,6 @@ lookupEnvConstructor :: Id -> Infer (VariantIx, (String, [TVar]), [Type])
lookupEnvConstructor (WithPos pos cx) =
    views envCtors (Map.lookup cx)
        >>= maybe (throwError (UndefCtor pos cx)) pure
    -- views envCtors (Map.lookup cx) >>= \case
    --     Just (Ast.TypeDef tx tps cs) ->
    --         case lookupConstructorParamTypes cx cs of
    --             Just cps -> pure (cps, (tx, tps))
    --             Nothing ->
    --                 ice
    --                     $ ("lookup failed for ctor `" ++ cx)
    --                     ++ ("` in type `" ++ tx ++ "`")
    --     Nothing -> throwError (UndefCtor pos cx)

-- lookupConstructorParamTypes :: String -> Ast.ConstructorDefs -> Maybe [Type]
-- lookupConstructorParamTypes cx (Ast.ConstructorDefs cs) = lookup cx cs

litType :: Const -> Type
litType = \case


@@ 340,49 424,6 @@ lookupEnv (WithPos pos x) = views envDefs (Map.lookup x) >>= \case
    Just scm -> instantiate scm
    Nothing -> throwError (UndefVar pos x)

-- Substitution
--------------------------------------------------------------------------------
substProgram :: Subst -> Program -> Program
substProgram s (Program main (Defs defs) tdefs) =
    Program (substExpr s main) (Defs (fmap (substDef s) defs)) tdefs

substDef :: Subst -> (Scheme, Expr) -> (Scheme, Expr)
substDef s = bimap id (substExpr s)

substExpr :: Subst -> Expr -> Expr
substExpr s = \case
    Lit c -> Lit c
    Var (TypedVar x t) -> Var (TypedVar x (subst s t))
    App f a -> App (substExpr s f) (substExpr s a)
    If p c a -> If (substExpr s p) (substExpr s c) (substExpr s a)
    Fun (p, tp) (b, bt) -> Fun (p, subst s tp) (substExpr s b, subst s bt)
    Let (Defs defs) body ->
        Let (Defs (fmap (substDef s) defs)) (substExpr s body)
    Match e cs -> Match
        (substExpr s e)
        (map (\(p, b) -> (substPat s p, substExpr s b)) cs)
    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 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
subst s t = case t of
    TVar tv -> fromMaybe t (Map.lookup tv s)
    TPrim _ -> t
    TFun a b -> TFun (subst s a) (subst s b)
    TConst (c, ts) -> TConst (c, (map (subst s) ts))

substEnv :: Subst -> Env -> Env
substEnv s = over (envDefs . mapped . scmBody) (subst s)

composeSubsts :: Subst -> Subst -> Subst
composeSubsts s1 s2 = Map.union (fmap (subst s1) s2) s1

-- Unification
--------------------------------------------------------------------------------
newtype ExpectedType = Expected Type


@@ 448,6 489,9 @@ generalize t = do
generalize' :: Env -> Type -> Set TVar
generalize' env t = Set.difference (ftv t) (ftvEnv env)

substEnv :: Subst -> Env -> Env
substEnv s = over (envDefs . mapped . scmBody) (subst s)

-- Free type variables
--------------------------------------------------------------------------------
ftv :: Type -> Set TVar

M src/Codegen.hs => src/Codegen.hs +70 -58
@@ 17,7 17,6 @@ import qualified LLVM.AST.Float as LLFloat
import qualified LLVM.AST.Global as LLGlob
import qualified LLVM.AST.AddrSpace as LLAddr
import qualified LLVM.AST.FunctionAttribute as LLFnAttr
import qualified LLVM.AST.IntegerPredicate as LLIntPred
import LLVM.Internal.DataLayout (withFFIDataLayout)
import LLVM.Internal.FFI.DataLayout (getTypeAllocSize)
import qualified LLVM.Internal.FFI.PtrHierarchy as LLPtrHierarchy


@@ 40,7 39,9 @@ import Data.Map.Strict (Map)
import qualified Data.Set as Set
import Data.Word
import Data.Foldable
import Data.Functor
import Data.List
import Data.Maybe
import Data.Composition
import Control.Applicative
import Control.Lens


@@ 251,7 252,7 @@ genExpr = \case
    If p c a -> genIf p c a
    Fun p b -> genLambda p b
    Let ds b -> genLet ds b
    Match e cs -> genMatch e cs
    Match e cs tbody -> genMatch e cs (toLlvmType tbody)
    Ction c -> genCtion c

toLlvmDataType :: MonoAst.TConst -> Type


@@ 345,54 346,63 @@ genLet (Defs ds) b = do
genDef :: (Name, Type, Expr) -> Gen Operand
genDef (n, t, e) = genVar n t (genExpr e)

genMatch :: Expr -> [(Pat, Expr)] -> Gen Operand
genMatch m cs = do
genMatch :: Expr -> DecisionTree -> Type -> Gen Operand
genMatch m dt tbody = do
    m' <- genExpr m
    nextL <- newName "next"
    nextCaseLs <- replicateM (length cs - 1) (newName "next_case")
    noMatchL <- newName "no_match"
    cs' <- zipWithM (genCase m' nextL) (nextCaseLs ++ [noMatchL]) cs
    -- If we fell through the last case, the pattern was nonexhaustive and we're
    -- in a failure state. Only thing to do now is panic!
    genAbort
    commitToNewBlock unreachable nextL
    emitAnon (phi cs')

genCase :: Operand -> Name -> Name -> (Pat, Expr) -> Gen (Operand, Name)
genCase m nextL nextCaseL (p, b) = do
    defs <- genMatchPattern nextCaseL m p
    b' <- withVars defs (genExpr b)
    l <- use currentBlockLabel
    commitToNewBlock (br nextL) nextCaseL
    pure (b', l)

genMatchPattern :: Name -> Operand -> Pat -> Gen [(TypedVar, Operand)]
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 tv -> do
        var <- genVar' tv (pure m)
        pure [(tv, var)]

genMatchPatterns :: Name -> Operand -> [Pat] -> Gen [(TypedVar, Operand)]
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)
    genDecisionTree [m'] tbody dt

-- | During eval of decision trees, put sub-matchees on a stack, and they will
--   be popped as we go out -> in, left -> right. Stack starts with matchee.
genDecisionTree :: [Operand] -> Type -> DecisionTree -> Gen Operand
genDecisionTree ms tbody = \case
    DecisionTree cs vdt -> if Map.null cs
        then genVdt vdt
        else do
            let (variantIxs, variantDts) = unzip (Map.toAscList cs)
            variantLs <- mapM
                (newName . (++ "_") . ("variant_" ++) . show)
                variantIxs
            let dests = zip (map litU64 variantIxs) variantLs
            defaultL <- newName "default"
            nextL <- newName "next"
            let (m, ms') = fromJust (uncons ms)
            mVariantIx <- emitReg'
                "found_variant_ix"
                (extractvalueFromNamed m i64 [0])
            commitToNewBlock (switch mVariantIx defaultL dests) defaultL
            v <- genVdt vdt
            let genCase l dt = do
                    commitToNewBlock (br nextL) l
                    genDecisionTree' m ms' tbody dt
            vs <- zipWithM genCase variantLs variantDts
            commitToNewBlock (br nextL) nextL
            emitAnon (phi (zip (v : vs) (defaultL : variantLs)))
    DecisionLeaf b -> genExpr b
  where
    genVdt = \case
        Just (tv, dt) ->
            withLocal tv (head ms) (genDecisionTree (tail ms) tbody dt)
        -- If we fell through the last case, the pattern was nonexhaustive
        -- and we're in a failure state. Only thing to do now is panic!
        Nothing -> genAbort $> undef tbody

genDecisionTree'
    :: Operand
    -> [Operand]
    -> Type
    -> ([MonoAst.Type], DecisionTree)
    -> Gen Operand
genDecisionTree' matchee stack tbody (ts, dt) = do
    let tvariant = toLlvmVariantType ts
    let tgeneric = typeOf matchee
    pGeneric <- emitReg' "ction_ptr_generic" (alloca tgeneric)
    emit (store matchee pGeneric)
    p <- emitReg' "ction_ptr" (bitcast pGeneric (LLType.ptr tvariant))
    matchee' <- emitReg' "ction" (load p)
    subs <- mapM
        (emitReg' "submatchee" . extractvalue matchee' . pure)
        (take (length ts) [1 ..])
    genDecisionTree (subs ++ stack) tbody dt

genCtion :: MonoAst.Ction -> Gen Operand
genCtion (i, tdef, as) = do


@@ 431,7 441,7 @@ genStruct xs = do
    let t = typeStruct (map typeOf xs)
    foldlM
        (\s (i, x) -> emitReg' "acc" (insertvalue s x [i]))
        (ConstantOperand (LLConst.Undef t))
        (undef t)
        (zip [0 ..] xs)

genBoxGeneric :: Operand -> Gen Operand


@@ 542,9 552,6 @@ withLocal x v gen = do
    vPtr <- genVar' x (pure v)
    withVar x vPtr gen

withVars :: [(TypedVar, Operand)] -> Gen a -> Gen a
withVars = flip (foldr (uncurry withVar))

-- | Takes a local value, allocates a variable for it, and runs a generator in
--   the environment with the variable
withVar :: TypedVar -> Operand -> Gen a -> Gen a


@@ 627,6 634,9 @@ callExtern'' f rt as = Call
    , metadata = []
    }

undef :: Type -> Operand
undef = ConstantOperand . LLConst.Undef

condbr :: Operand -> Name -> Name -> Terminator
condbr c t f = CondBr c t f []



@@ 636,8 646,8 @@ br = flip Br []
ret :: Operand -> Terminator
ret = flip Ret [] . Just

unreachable :: Terminator
unreachable = Unreachable []
switch :: Operand -> Name -> [(LLConst.Constant, Name)] -> Terminator
switch x def cs = Switch x def cs []

bitcast :: Operand -> Type -> FunInstruction
bitcast x t = WithRetType (BitCast x t []) t


@@ 650,6 660,11 @@ extractvalue struct is = WithRetType
    (ExtractValue { aggregate = struct, indices' = is, metadata = [] })
    (getIndexed (typeOf struct) is)

extractvalueFromNamed :: Operand -> Type -> [Word32] -> FunInstruction
extractvalueFromNamed struct t is = WithRetType
    (ExtractValue { aggregate = struct, indices' = is, metadata = [] })
    t

store :: Operand -> Operand -> Instruction
store srcVal destPtr = Store
    { volatile = False


@@ 694,9 709,6 @@ call f as = WithRetType
alloca :: Type -> FunInstruction
alloca t = WithRetType (Alloca t Nothing 0 []) (LLType.ptr t)

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

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


M src/FreeVars.hs => src/FreeVars.hs +1 -21
@@ 1,16 1,6 @@
{-# LANGUAGE MultiParamTypeClasses, LambdaCase #-}

module FreeVars
    ( FreeVars(..)
    , Pattern(..)
    , fvApp
    , fvIf
    , fvFun
    , fvLet
    , fvMatch
    , fvCases
    )
where
module FreeVars (FreeVars(..), fvApp, fvIf, fvFun, fvLet) where

import qualified Data.Set as Set
import Data.Set (Set)


@@ 19,9 9,6 @@ import Data.Foldable
class Ord b => FreeVars a b where
    freeVars :: a -> Set b

class Ord b => Pattern a b where
    patternBoundVars :: a -> Set b

fvApp :: FreeVars e t => e -> e -> Set t
fvApp f a = Set.unions (map freeVars [f, a])



@@ 35,10 22,3 @@ fvLet :: (FreeVars e t, Foldable f) => (Set t, f e) -> e -> Set t
fvLet (bVs, bBs) b = Set.difference
    (Set.union (freeVars b) (foldr (Set.union . freeVars) Set.empty bBs))
    (Set.fromList (toList bVs))

fvMatch :: (Pattern p t, FreeVars e t) => e -> [(p, e)] -> Set t
fvMatch e cs = Set.union (freeVars e) (fvCases cs)

fvCases :: (Pattern p t, FreeVars e t) => [(p, e)] -> Set t
fvCases = Set.unions
    . map (\(p, e) -> Set.difference (freeVars e) (patternBoundVars p))

M src/Interp.hs => src/Interp.hs +30 -16
@@ 9,6 9,7 @@ import Data.Functor
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as Map
import Data.Maybe
import Data.List

import Misc
import MonoAst


@@ 64,7 65,9 @@ eval = \case
        env <- ask
        pure (VFun (\v -> runEval (withLocals env (withLocal p v (eval b)))))
    Let defs body -> evalLet defs body
    Match e cs -> eval e >>= flip evalCases cs
    Match e dt _ -> do
        v <- eval e
        evalDecisionTree [v] dt
    Ction (i, _, as) -> fmap (VConstruction i) (mapM eval as)

evalApp :: Expr -> Expr -> Eval Val


@@ 77,21 80,32 @@ evalLet defs body = do
    defs' <- evalDefs defs
    withLocals defs' (eval body)

evalCases :: Val -> [(Pat, Expr)] -> Eval Val
evalCases matchee = \case
    [] -> ice "Non-exhaustive patterns in match. Fell out!"
    (p, b) : cs -> matchPat matchee p >>= \case
        Just defs -> withLocals defs (eval b)
        Nothing -> evalCases matchee cs

matchPat :: Val -> Pat -> Eval (Maybe (Map TypedVar Val))
matchPat = curry $ \case
    (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
    (x, PVar v) -> pure (Just (Map.singleton v x))
-- | Out to in, left to right.
evalDecisionTree :: [Val] -> DecisionTree -> Eval Val
evalDecisionTree stack = \case
    DecisionTree cs default' -> do
        let
            (m, ms) = fromMaybe
                (ice "Stack is empty in evalDecisionTree")
                (uncons stack)
        evalDecisionTree' m ms cs >>= \case
            Just v -> pure v
            Nothing -> case default' of
                Just (tv, d) -> withLocal tv m (evalDecisionTree ms d)
                Nothing ->
                    ice "default' is Nothing after fail in evalDecisionTree"
    DecisionLeaf e -> eval e

evalDecisionTree'
    :: Val
    -> [Val]
    -> Map VariantIx (VariantTypes, DecisionTree)
    -> Eval (Maybe Val)
evalDecisionTree' m ms cs = case m of
    VConstruction ctor xs -> case Map.lookup ctor cs of
        Just (_, d) -> fmap Just (evalDecisionTree (xs ++ ms) d)
        Nothing -> pure Nothing
    _ -> pure Nothing

lookupEnv :: (String, Type) -> Eval Val
lookupEnv (x, t) = fmap

M src/Misc.hs => src/Misc.hs +9 -0
@@ 13,12 13,15 @@ module Misc
    , showChar'
    , both
    , augment
    , insertOrPrefix
    , insertWith'
    )
where

import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Composition
import Control.Monad.Reader
import Control.Lens (Lens', locally)



@@ 79,3 82,9 @@ both f (a0, a1) = (f a0, f a1)
augment
    :: (MonadReader e m, Ord k) => Lens' e (Map k v) -> Map k v -> m a -> m a
augment l = locally l . Map.union

insertOrPrefix :: (Ord k, Monoid v) => k -> v -> Map k v -> Map k v
insertOrPrefix k v = insertWith' (mappend v) k v

insertWith' :: Ord k => (v -> v) -> k -> v -> Map k v -> Map k v
insertWith' f = Map.insertWith (f .* flip const)

M src/Mono.hs => src/Mono.hs +19 -28
@@ 14,6 14,7 @@ import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Bitraversable

import Misc
import qualified AnnotAst as An


@@ 58,7 59,7 @@ mono = \case
    An.If p c a -> liftA3 If (mono p) (mono c) (mono a)
    An.Fun p b -> monoFun p b
    An.Let ds b -> fmap (uncurry Let) (monoLet ds b)
    An.Match e cs -> monoMatch e cs
    An.Match e cs tbody -> monoMatch e cs tbody
    An.Ction c -> monoCtion c

monoFun :: (String, An.Type) -> (An.Expr, An.Type) -> Mono Expr


@@ 86,30 87,23 @@ monoLet (An.Defs ds) body = do
            pure (TypedVar name t, body)
    pure (Defs ds', body')

monoMatch :: An.Expr -> [(An.Pat, An.Expr)] -> Mono Expr
monoMatch e cs = do
    e' <- mono e
    cs' <- mapM monoCase cs
    pure (Match e' cs')

monoCase :: (An.Pat, An.Expr) -> Mono (Pat, Expr)
monoCase (p, e) = do
    (p', pvs) <- monoPat p
    let pvs' = Set.toList pvs
    parentInsts <- uses defInsts (lookups pvs')
    modifying defInsts (deletes pvs')
    e' <- mono e
    modifying defInsts (Map.union (Map.fromList parentInsts))
    pure (p', e')

monoPat :: An.Pat -> Mono (Pat, Set String)
monoPat = \case
    An.PConstruction c ts ps -> do
        ts' <- mapM monotype ts
        (ps', bvs) <- fmap unzip (mapM monoPat ps)
        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)
monoMatch :: An.Expr -> An.DecisionTree -> An.Type -> Mono Expr
monoMatch e dt tbody =
    liftA3 Match (mono e) (monoDecisionTree dt) (monotype tbody)

monoDecisionTree :: An.DecisionTree -> Mono DecisionTree
monoDecisionTree = \case
    An.DecisionTree cs vdt -> do
        cs' <- mapM (bimapM (mapM monotype) monoDecisionTree) cs
        vdt' <- flip (maybe (pure Nothing)) vdt $ \(An.TypedVar x t, dt) -> do
            parentInst <- uses defInsts (Map.lookup x)
            modifying defInsts (Map.delete x)
            t' <- monotype t
            dt' <- monoDecisionTree dt
            maybe (pure ()) (modifying defInsts . Map.insert x) parentInst
            pure (Just (TypedVar x t', dt'))
        pure (DecisionTree cs' vdt')
    An.DecisionLeaf e -> fmap DecisionLeaf (mono e)

monoCtion :: An.Ction -> Mono Expr
monoCtion (i, (tdefName, tdefArgs), as) = do


@@ 180,6 174,3 @@ lookup' = Map.findWithDefault

lookups :: Ord k => [k] -> Map k v -> [(k, v)]
lookups ks m = catMaybes (map (\k -> fmap (k, ) (Map.lookup k m)) ks)

deletes :: (Foldable t, Ord k) => t k -> Map k v -> Map k v
deletes = flip (foldr Map.delete)

M src/MonoAst.hs => src/MonoAst.hs +17 -15
@@ 8,10 8,11 @@ module MonoAst
    , TConst
    , Type(..)
    , TypedVar(..)
    , Const(..)
    , VariantIx
    , Pat(..)
    , VariantTypes
    , DecisionTree(..)
    , Ction
    , Const(..)
    , Expr(..)
    , Defs(..)
    , TypeDefs


@@ 42,10 43,11 @@ data TypedVar = TypedVar String Type

type VariantTypes = [Type]

data Pat
    = PConstruction VariantIx VariantTypes [Pat]
    | PVar TypedVar
    deriving (Show, Eq)
data DecisionTree
    = DecisionTree (Map VariantIx (VariantTypes, DecisionTree))
                   (Maybe (TypedVar, DecisionTree))
    | DecisionLeaf Expr
    deriving (Show)

-- | (Variant index, constructed type, arguments)
type Ction = (VariantIx, TConst, [Expr])


@@ 57,7 59,7 @@ data Expr
    | If Expr Expr Expr
    | Fun TypedVar (Expr, Type)
    | Let Defs Expr
    | Match Expr [(Pat, Expr)]
    | Match Expr DecisionTree Type
    | Ction Ction
    deriving (Show)



@@ 73,9 75,6 @@ data Program = Program Expr Defs TypeDefs
instance FreeVars Expr TypedVar where
    freeVars = fvExpr

instance Pattern Pat TypedVar where
    patternBoundVars = bvPat


fvExpr :: Expr -> Set TypedVar
fvExpr = \case


@@ 85,13 84,16 @@ fvExpr = \case
    If p c a -> fvIf p c a
    Fun p (b, _) -> fvFun p b
    Let (Defs bs) e -> fvLet (Map.keysSet bs, Map.elems bs) e
    Match e cs -> fvMatch e cs
    Match e dt _ -> Set.union (fvExpr e) (fvDecisionTree dt)
    Ction (_, _, as) -> Set.unions (map fvExpr as)

bvPat :: Pat -> Set TypedVar
bvPat = \case
    PConstruction _ _ ps -> Set.unions (map bvPat ps)
    PVar x -> Set.singleton x
fvDecisionTree :: DecisionTree -> Set TypedVar
fvDecisionTree = \case
    DecisionTree cs vdt ->
        Set.unions
            $ maybe Set.empty (\(v, dt) -> Set.delete v (fvDecisionTree dt)) vdt
            : map (fvDecisionTree . snd) (Map.elems cs)
    DecisionLeaf e -> fvExpr e

mainType :: Type
mainType = TFun (TPrim TUnit) (TPrim TUnit)

M src/Parse.hs => src/Parse.hs +10 -12
@@ 14,7 14,7 @@ module Parse
    , parse'
    , reserveds
    , ns_scheme
    , ns_patCtion
    , ns_pat
    , var
    , eConstructor
    , ns_expr


@@ 161,18 161,16 @@ case' :: Parser (Pat, Expr)
case' = parens (liftM2 (,) pat expr)

pat :: Parser Pat
pat = patCtor <|> patCtion <|> patVar
  where
    patCtor = fmap (\x -> PConstruction (getPos x) x []) big'
    patVar = fmap PVar small'

patCtion :: Parser Pat
patCtion = andSkipSpaceAfter ns_patCtion
pat = andSkipSpaceAfter ns_pat

ns_patCtion :: Parser Pat
ns_patCtion = do
    pos <- getSrcPos
    ns_parens (liftM3 PConstruction (pure pos) big' (some pat))
ns_pat :: Parser Pat
ns_pat = patCtor <|> patCtion <|> patVar
  where
    patCtor = fmap (\x -> PConstruction (getPos x) x []) ns_big'
    patVar = fmap PVar ns_small'
    patCtion = do
        pos <- getSrcPos
        ns_parens (liftM3 PConstruction (pure pos) big' (some pat))

app :: Parser Expr'
app = do

A src/Subst.hs => src/Subst.hs +105 -0
@@ 0,0 1,105 @@
{-# LANGUAGE LambdaCase #-}

module Subst
    ( Subst
    , subst
    , substProgram
    , composeSubsts
    , VarSubst
    , substVExpr
    )
where

import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.Bifunctor
import Data.Maybe

import AnnotAst

-- | Map of substitutions from type-variables to more specific types
type Subst = Map TVar Type

type VarSubst = (String, String)

substProgram :: Subst -> Program -> Program
substProgram s (Program main (Defs defs) tdefs) =
    Program (substExpr s main) (Defs (fmap (substDef s) defs)) tdefs

substDef :: Subst -> (Scheme, Expr) -> (Scheme, Expr)
substDef s = second (substExpr s)

substExpr :: Subst -> Expr -> Expr
substExpr s = \case
    Lit c -> Lit c
    Var (TypedVar x t) -> Var (TypedVar x (subst s t))
    App f a -> App (substExpr s f) (substExpr s a)
    If p c a -> If (substExpr s p) (substExpr s c) (substExpr s a)
    Fun (p, tp) (b, bt) -> Fun (p, subst s tp) (substExpr s b, subst s bt)
    Let (Defs defs) body ->
        Let (Defs (fmap (substDef s) defs)) (substExpr s body)
    Match e dt tbody ->
        Match (substExpr s e) (substDecisionTree s dt) (subst s tbody)
    Ction (i, (tx, tts), es) ->
        Ction (i, (tx, map (subst s) tts), map (substExpr s) es)

substDecisionTree :: Subst -> DecisionTree -> DecisionTree
substDecisionTree s = \case
    DecisionTree cs vdt -> DecisionTree
        (fmap (\(ts, dt) -> (map (subst s) ts, substDecisionTree s dt)) cs)
        (fmap
            (\(TypedVar x t, dt) ->
                (TypedVar x (subst s t), substDecisionTree s dt)
            )
            vdt
        )
    DecisionLeaf e -> DecisionLeaf (substExpr s e)

subst :: Subst -> Type -> Type
subst s t = case t of
    TVar tv -> fromMaybe t (Map.lookup tv s)
    TPrim _ -> t
    TFun a b -> TFun (subst s a) (subst s b)
    TConst (c, ts) -> TConst (c, (map (subst s) ts))

composeSubsts :: Subst -> Subst -> Subst
composeSubsts s1 s2 = Map.union (fmap (subst s1) s2) s1

substVExpr :: VarSubst -> Expr -> Expr
substVExpr s = \case
    Lit c -> Lit c
    Var (TypedVar x t) -> Var (TypedVar (substV s x) t)
    App f a -> App (substVExpr s f) (substVExpr s a)
    If p c a -> If (substVExpr s p) (substVExpr s c) (substVExpr s a)
    Fun p b -> substVFun s p b
    Let (Defs defs) body -> substVLet s defs body
    Match e dt t -> Match (substVExpr s e) (substVDecisionTree s dt) t
    Ction (i, t, es) -> Ction (i, t, map (substVExpr s) es)

substVFun :: VarSubst -> (String, Type) -> (Expr, Type) -> Expr
substVFun s@(from, _) p@(p', _) b@(b', tb) =
    if p' == from then Fun p b else Fun p (substVExpr s b', tb)

substVLet :: VarSubst -> Map String (Scheme, Expr) -> Expr -> Expr
substVLet s@(from, _) defs body =
    let
        defs' = Map.mapWithKey
            (\k (scm, e) -> (scm, if from == k then e else substVExpr s e))
            defs
        body' = if Map.member from defs then body else substVExpr s body
    in Let (Defs defs') body'

substVDecisionTree :: VarSubst -> DecisionTree -> DecisionTree
substVDecisionTree s = \case
    DecisionTree cs vdt -> DecisionTree
        (fmap (\(ts, dt) -> (ts, substVDecisionTree s dt)) cs)
        (fmap
            (\(TypedVar x t, dt) ->
                (TypedVar (substV s x) t, substVDecisionTree s dt)
            )
            vdt
        )
    DecisionLeaf e -> DecisionLeaf (substVExpr s e)

substV :: VarSubst -> String -> String
substV (from, to) var = if var == from then to else var

M src/TypeErr.hs => src/TypeErr.hs +4 -2
@@ 23,6 23,7 @@ data TypeErr
    | UnificationFailed SrcPos Type Type Type Type
    | ConflictingTypeDef Id
    | ConflictingCtorDef Id
    | RedundantCase SrcPos

type Message = String



@@ 34,7 35,7 @@ prettyErr = \case
            $ ("Invalid user type signature " ++ pretty s1)
            ++ (", expected " ++ pretty s2)
    CtorArityMismatch p c arity nArgs ->
        posd p patCtion
        posd p pat
            $ ("Arity mismatch for constructor `" ++ pretty c)
            ++ ("` in pattern.\nExpected " ++ show arity)
            ++ (", found " ++ show nArgs)


@@ 61,6 62,7 @@ prettyErr = \case
        posd p big $ "Conflicting definitions for type `" ++ x ++ "`."
    ConflictingCtorDef (WithPos p x) ->
        posd p big $ "Conflicting definitions for constructor `" ++ x ++ "`."
    RedundantCase p -> posd p pat $ "Redundant case in pattern match."
  where
    -- | Used to handle that the position of the generated nested lambdas of a
    --   definition of the form `(define (foo a b ...) ...)` is set to the


@@ 70,7 72,7 @@ prettyErr = \case
            <||> Parse.ns_expr
            <||> wholeLine
    scheme = Parse.ns_scheme <||> wholeLine
    patCtion = Parse.ns_patCtion <||> wholeLine
    pat = Parse.ns_pat <||> wholeLine
    var = Parse.var <||> wholeLine
    eConstructor = Parse.eConstructor <||> wholeLine
    big = Parse.ns_big