~jojo/Carth

ref: 55fb4f948f1f3797078b584dc60b4f7dd68b37ed Carth/src/Lower.hs -rw-r--r-- 3.4 KiB
55fb4f94JoJo Check `cast` in Infer instead of Gen 4 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
module Lower (lower, builtinExterns) where

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

import Misc
import SrcPos
import qualified Monomorphic as Ast
import qualified Monomorphize
import Low


lower :: Ast.Program -> Program
lower (Ast.Program defs datas externs) =
    Program (lowerDefs defs) (lowerDatas datas) (lowerExterns externs)

builtinExterns :: Map String Type
builtinExterns = fmap lowerType Monomorphize.builtinExterns

lowerDefs :: Ast.Defs -> Defs
lowerDefs (Topo defs) = Topo $ map lowerDef defs

lowerDef :: Ast.Def -> Def
lowerDef = \case
    Ast.VarDef d -> VarDef $ lowerVarDef d
    Ast.RecDefs ds -> RecDefs $ lowerRecDefs ds

lowerVarDef :: Ast.VarDef -> VarDef
lowerVarDef = bimap lowerTypedVar (bimap (map lowerType) (fmap lowerExpr'))

lowerRecDefs :: Ast.RecDefs -> RecDefs
lowerRecDefs = map lowerFunDef

lowerFunDef :: Ast.FunDef -> FunDef
lowerFunDef = bimap lowerTypedVar (bimap (map lowerType) (fmap lowerFun))

lowerFun :: Ast.Fun -> Fun
lowerFun = bimap lowerTypedVar (bimap lowerExpr lowerType)

lowerExpr :: Ast.Expr -> Expr
lowerExpr (Ast.Expr p e) = Expr p (lowerExpr' e)

lowerExpr' :: Ast.Expr' -> Expr'
lowerExpr' = \case
    Ast.Lit c -> Lit c
    Ast.Var v -> Var $ second lowerTypedVar v
    Ast.App f a -> lowerApp f [a]
    Ast.If p c a -> If (lowerExpr p) (lowerExpr c) (lowerExpr a)
    Ast.Fun f -> Fun (lowerFun f)
    Ast.Let d e -> Let (lowerDef d) (lowerExpr e)
    Ast.Match m dt t -> Match (lowerExpr m) (lowerDecisionTree dt) (lowerType t)
    Ast.Ction c -> Ction $ lowerCtion c
    Ast.Sizeof t -> Sizeof $ lowerType t
    Ast.Absurd t -> Absurd $ lowerType t

-- | Performs a sort of beta reduction
lowerApp :: Ast.Expr -> [Ast.Expr] -> Expr'
lowerApp = curry $ \case
    (Ast.Expr _ (Ast.Fun (p, (b, _))), Ast.Expr _ a : as) -> Let
        (VarDef
            ( lowerTypedVar p
            -- FIXME: This pos is pretty bad probably?
            , ( uniqueInst
              , WithPos (ice "read srcpos of VarDef from lowerApp") (lowerExpr' a)
              )
            )
        )
        (Expr Nothing (lowerApp b as))
    (Ast.Expr _ (Ast.App f a), as) -> lowerApp f (a : as)
    (Ast.Expr _ f, []) -> lowerExpr' f
    (f, as) -> App (lowerExpr f) (map lowerExpr as)
    where uniqueInst = []

lowerDecisionTree :: Ast.DecisionTree -> DecisionTree
lowerDecisionTree = \case
    Ast.DLeaf (bs, e) -> DLeaf (map (bimap lowerTypedVar lowerAccess) bs, lowerExpr e)
    Ast.DSwitch a cs def ->
        DSwitch (lowerAccess a) (fmap lowerDecisionTree cs) (lowerDecisionTree def)
    Ast.DSwitchStr a cs def ->
        DSwitchStr (lowerAccess a) (fmap lowerDecisionTree cs) (lowerDecisionTree def)

lowerAccess :: Ast.Access -> Access
lowerAccess = fmap lowerType

lowerCtion :: Ast.Ction -> Ction
lowerCtion (i, s, tc, es) = (i, s, lowerTConst tc, map lowerExpr es)

lowerDatas :: Ast.Datas -> Datas
lowerDatas = Map.fromList . map (bimap lowerTConst (map (map lowerType))) . Map.toList

lowerExterns :: Ast.Externs -> Externs
lowerExterns = map (\(x, t, p) -> (x, lowerType t, p))

lowerTypedVar :: Ast.TypedVar -> TypedVar
lowerTypedVar (Ast.TypedVar x t) = TypedVar x (lowerType t)

lowerTConst :: Ast.TConst -> TConst
lowerTConst = second (map lowerType)

lowerType :: Ast.Type -> Type
lowerType = \case
    Ast.TPrim p -> TPrim p
    Ast.TFun a r -> TFun (lowerType a) (lowerType r)
    Ast.TBox t -> TBox (lowerType t)
    Ast.TConst tc -> TConst (lowerTConst tc)