~jojo/Carth

65fedc5ad30893bac36f128dac201ff7081f8e1b — JoJo 1 year, 6 months ago 0088875
Allow Box in pattern to dereference
M src/AnnotAst.hs => src/AnnotAst.hs +5 -1
@@ 39,7 39,11 @@ data TypedVar = TypedVar Id Type

type VariantIx = Integer

data Access = Obj | As Access Span [Type] | Sel Word32 Span Access
data Access
    = Obj
    | As Access Span [Type]
    | Sel Word32 Span Access
    | ADeref Access
    deriving (Show, Eq, Ord)

type Span = Integer

M src/Ast.hs => src/Ast.hs +4 -0
@@ 85,6 85,7 @@ data Pat
    | PInt SrcPos Int
    | PBool SrcPos Bool
    | PVar (Id 'Small)
    | PBox SrcPos Pat
    deriving Show

data Const


@@ 149,6 150,7 @@ instance HasPos Pat where
        PInt p _ -> p
        PBool p _ -> p
        PVar v -> getPos v
        PBox p _ -> p

instance Pretty Program where
    pretty' = prettyProg


@@ 204,6 206,7 @@ bvPat = \case
    PInt _ _ -> Set.empty
    PBool _ _ -> Set.empty
    PVar x -> Set.singleton x
    PBox _ p -> bvPat p

prettyProg :: Int -> Program -> String
prettyProg d (Program defs tdefs externs) =


@@ 308,6 311,7 @@ prettyPat = \case
    PInt _ n -> show n
    PBool _ b -> if b then "true" else "false"
    PVar v -> idstr v
    PBox _ p -> "(Box " ++ prettyPat p ++ ")"

prettyConst :: Const -> String
prettyConst = \case

M src/Codegen.hs => src/Codegen.hs +11 -7
@@ 395,7 395,7 @@ genDecisionSwitch selector cs def tbody selections = do
    variantLs <- mapM (newName . (++ "_") . ("variant_" ++) . show) variantIxs
    defaultL <- newName "default"
    nextL <- newName "next"
    (m, selections') <- select genAs genSub selector selections
    (m, selections') <- select selAs selSub selDeref selector selections
    mVariantIx <- case typeOf m of
        IntegerType _ -> pure m
        _ -> emitReg' "found_variant_ix" =<< extractvalue m [0]


@@ 416,10 416,11 @@ genDecisionSwitch selector cs def tbody selections = do

genDecisionLeaf :: (MonoAst.VarBindings, Expr) -> Selections Operand -> Gen Val
genDecisionLeaf (bs, e) selections =
    flip withLocals (genExpr e) =<< selectVarBindings genAs genSub selections bs
    flip withLocals (genExpr e)
        =<< selectVarBindings selAs selSub selDeref selections bs

genAs :: Span -> [MonoAst.Type] -> Operand -> Gen Operand
genAs totVariants ts matchee = do
selAs :: Span -> [MonoAst.Type] -> Operand -> Gen Operand
selAs totVariants ts matchee = do
    tvariant <- lift (genVariantType totVariants ts)
    let tgeneric = typeOf matchee
    pGeneric <- emitReg' "ction_ptr_generic" (alloca tgeneric)


@@ 427,11 428,14 @@ genAs totVariants ts matchee = do
    p <- emitReg' "ction_ptr" (bitcast pGeneric (LLType.ptr tvariant))
    emitReg' "ction" (load p)

genSub :: Span -> Word32 -> Operand -> Gen Operand
genSub span' i matchee =
selSub :: Span -> Word32 -> Operand -> Gen Operand
selSub span' i matchee =
    let tagOffset = if span' > 1 then 1 else 0
    in emitReg' "submatchee" =<< extractvalue matchee (pure (tagOffset + i))

selDeref :: Operand -> Gen Operand
selDeref x = emitAnon (load x)

genCtion :: MonoAst.Ction -> Gen Val
genCtion (i, span', dataType, as) = do
    as' <- mapM genExpr as


@@ 505,7 509,7 @@ genHeapAlloc t = do

genDeref :: Expr -> Gen Val
genDeref e = genExpr e >>= \case
    VVar x -> fmap VVar (emitAnon (load x))
    VVar x -> fmap VVar (selDeref x)
    VLocal x -> pure (VVar x)

getVar :: Val -> Gen Operand

M src/Infer.hs => src/Infer.hs +3 -0
@@ 251,6 251,9 @@ inferPat = \case
    Ast.PVar x@(Id x') -> do
        tv <- fresh
        pure (tv, PVar (TypedVar x' tv), Map.singleton x (Forall Set.empty tv))
    Ast.PBox _ p -> do
        (tp', p', vs) <- inferPat p
        pure (TBox tp', PBox p', vs)
  where
    intToPCon n w = PCon
        (Con

M src/Match.hs => src/Match.hs +2 -0
@@ 37,6 37,7 @@ data Pat
    = PVar TypedVar
    | PWild
    | PCon Con [Pat]
    | PBox Pat
    deriving Show

data Descr = Pos Con [Descr] | Neg (Set Con)


@@ 142,6 143,7 @@ match
match obj descr ctx work rhs rules = \case
    PVar x -> conjunct (augment descr ctx) (addBind x obj rhs) rules work
    PWild -> conjunct (augment descr ctx) rhs rules work
    PBox p -> match (ADeref obj) descr ctx work rhs rules p
    PCon pcon pargs ->
        let
            disjunct' :: Descr -> Match DecisionTree'

M src/Mono.hs => src/Mono.hs +1 -0
@@ 127,6 127,7 @@ monoAccess = \case
    An.As a span' ts ->
        liftA3 As (monoAccess a) (pure span') (mapM monotype ts)
    An.Sel i span' a -> fmap (Sel i span') (monoAccess a)
    An.ADeref a -> fmap ADeref (monoAccess a)

monoCtion :: VariantIx -> Span -> An.TConst -> [An.Expr] -> Mono Expr
monoCtion i span' (tdefName, tdefArgs) as = do

M src/MonoAst.hs => src/MonoAst.hs +5 -1
@@ 48,7 48,11 @@ data TypedVar = TypedVar String Type

type VariantTypes = [Type]

data Access = Obj | As Access Span [Type] | Sel Word32 Span Access
data Access
    = Obj
    | As Access Span [Type]
    | Sel Word32 Span Access
    | ADeref Access
    deriving (Show, Eq, Ord)

type VarBindings = [(TypedVar, Access)]

M src/Parse.hs => src/Parse.hs +5 -3
@@ 221,15 221,17 @@ pat :: Parser Pat
pat = andSkipSpaceAfter ns_pat

ns_pat :: Parser Pat
ns_pat = choice [patInt, patBool, patCtor, patCtion, patVar]
ns_pat = choice [patInt, patBool, patCtor, patVar, ppat]
  where
    patInt = liftA2 PInt getSrcPos int
    patBool = liftA2 PBool getSrcPos bool
    patCtor = fmap (\x -> PConstruction (getPos x) x []) ns_big'
    patVar = fmap PVar ns_small'
    patCtion = do
    ppat = do
        pos <- getSrcPos
        ns_parens (liftM3 PConstruction (pure pos) big' (some pat))
        ns_parens (choice [patBox pos, patCtion pos])
    patBox pos = reserved "Box" *> fmap (PBox pos) pat
    patCtion pos = liftM3 PConstruction (pure pos) big' (some pat)

app :: Parser Expr'
app = do

M src/Selections.hs => src/Selections.hs +23 -16
@@ 21,34 21,41 @@ select
    :: (Show a, Monad m)
    => (Span -> [Type] -> a -> m a)
    -> (Span -> Word32 -> a -> m a)
    -> (a -> m a)
    -> Access
    -> Selections a
    -> m (a, Selections a)
select conv sub selector selections = case Map.lookup selector selections of
    Just a -> pure (a, selections)
    Nothing -> do
        (a, selections') <- case selector of
            Obj -> ice "select: Obj not in selections"
            As x span' ts -> do
                (a', s') <- select conv sub x selections
                a'' <- conv span' ts a'
                pure (a'', s')
            Sel i span' x -> do
                (a', s') <- select conv sub x selections
                a'' <- sub span' i a'
                pure (a'', s')
        pure (a, Map.insert selector a selections')
select conv sub deref selector selections =
    case Map.lookup selector selections of
        Just a -> pure (a, selections)
        Nothing -> do
            (a, selections') <- case selector of
                Obj -> ice "select: Obj not in selections"
                As x span' ts -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- conv span' ts a'
                    pure (a'', s')
                Sel i span' x -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- sub span' i a'
                    pure (a'', s')
                ADeref x -> do
                    (a', s') <- select conv sub deref x selections
                    a'' <- deref a'
                    pure (a'', s')
            pure (a, Map.insert selector a selections')

selectVarBindings
    :: (Show a, Monad m)
    => (Span -> [Type] -> a -> m a)
    -> (Span -> Word32 -> a -> m a)
    -> (a -> m a)
    -> Selections a
    -> VarBindings
    -> m [(TypedVar, a)]
selectVarBindings conv sub selections = fmap fst . foldM
selectVarBindings conv sub deref selections = fmap fst . foldM
    (\(bs', ss) (x, s) -> do
        (a, ss') <- select conv sub s ss
        (a, ss') <- select conv sub deref s ss
        pure ((x, a) : bs', ss')
    )
    ([], selections)

M src/Subst.hs => src/Subst.hs +2 -0
@@ 49,11 49,13 @@ substAccess s = \case
    Obj -> Obj
    As a span' ts -> As (substAccess s a) span' (map (subst s) ts)
    Sel i span' a -> Sel i span' (substAccess s a)
    ADeref a -> ADeref (substAccess s a)

substPat :: Subst -> Pat -> Pat
substPat s = \case
    PWild -> PWild
    PVar v -> PVar (substTypedVar s v)
    PBox p -> PBox (substPat s p)
    PCon c ps -> PCon (substCon s c) (map (substPat s) ps)

substCon :: Subst -> Con -> Con