Skip to content

Commit 24c41c0

Browse files
jazullojazullo
authored
Merge pull request #253 from iu-parfunc/jazullo/newtype-elimination
Jazullo/newtype-elimination
2 parents a04e531 + aef59c1 commit 24c41c0

File tree

11 files changed

+185
-7
lines changed

11 files changed

+185
-7
lines changed

‎gibbon-compiler/examples/poly/Poly1.ans‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
'#(10 #t 11 #f 2 4 (Nothing_v_295 ) (Right_v_315 20) (Right_v_306 1) 12 #f 0 3 (Cons_v_301 1(Cons_v_301 2(Nil_v_301 ))) (Cons_v_301 1(Cons_v_301 2(Nil_v_301 ))) (Right_v_306 1) (Cons_v_301 11(Cons_v_301 12(Nil_v_301 ))))
1+
'#(10 #t 11 #f 2 4 (Nothing_v_406) (Right_v_426 20) (Right_v_417 1) 12 #f 0 3 (Cons_v_412 1 (Cons_v_412 2 (Nil_v_412))) (Cons_v_412 1 (Cons_v_412 2 (Nil_v_412))) (Right_v_417 1) (Cons_v_412 11 (Cons_v_412 12 (Nil_v_412))))

‎gibbon-compiler/examples/test_153.ans‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
'#((A_v_11 2 3) (B_v_12 4 5))
1+
'#('#(2 3) (B_v_13 4 5))

‎gibbon-compiler/examples/test_164.ans‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
(Cons_v_46 3 (Cons_v_46 5 (Cons_v_46 7 (Nil_v_46))))
1+
(Cons_v_64 3 (Cons_v_64 5 (Cons_v_64 7 (Nil_v_64))))

‎gibbon-compiler/examples/test_166.ans‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
(Node_v_54 10 10 10 10 10 10 10 10 (Cell_v_54 5 5 5 5 5 5 5 5) (Cell_v_54 2 2 2 2 2 2 2 2))
1+
(Node_v_79 10 10 10 10 10 10 10 10 (Cell_v_79 5 5 5 5 5 5 5 5) (Cell_v_79 2 2 2 2 2 2 2 2))

‎gibbon-compiler/gibbon.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ library
3939

4040
Gibbon.L0.Syntax
4141
Gibbon.L0.Typecheck
42+
Gibbon.L0.ElimNewtype
4243
Gibbon.L0.Specialize2
4344
Gibbon.L0.Interp
4445
Gibbon.L1.Syntax

‎gibbon-compiler/src/Gibbon/Compiler.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ import Gibbon.L2.Interp ( Store, emptyStore )
5656
-- Compiler passes
5757
import qualified Gibbon.L0.Typecheck as L0
5858
import qualified Gibbon.L0.Specialize2 as L0
59+
import qualified Gibbon.L0.ElimNewtype as L0
5960
import qualified Gibbon.L1.Typecheck as L1
6061
import qualified Gibbon.L2.Typecheck as L2
6162
import qualified Gibbon.L3.Typecheck as L3
@@ -641,6 +642,8 @@ passes config@Config{dynflags} l0 = do
641642
tcProg3 = L3.tcProg isPacked
642643
l0 <- go "freshen" freshNames l0
643644
l0 <- goE0 "typecheck" L0.tcProg l0
645+
l0 <- go "elimNewtypes" L0.elimNewtypes l0
646+
l0 <- goE0 "typecheck" L0.tcProg l0
644647
l0 <- goE0 "bindLambdas" L0.bindLambdas l0
645648
l0 <- goE0 "monomorphize" L0.monomorphize l0
646649
-- l0 <- goE0 "closureConvert" L0.closureConvert l0

‎gibbon-compiler/src/Gibbon/L0/ElimNewtype.hs‎

Lines changed: 155 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,155 @@
1+
module Gibbon.L0.ElimNewtype where
2+
3+
import Gibbon.L0.Syntax
4+
import Gibbon.Common
5+
6+
import Control.Arrow
7+
import qualified Data.Map as M
8+
import qualified Data.Set as S
9+
import Data.Symbol ( unintern )
10+
11+
elimNewtypes :: Monad m => Prog0 -> m Prog0
12+
elimNewtypes = pure . elimProgram
13+
14+
packedOccurs :: Var -> Ty0 -> Bool
15+
packedOccurs v@(Var s) t = case t of
16+
PackedTy u ts
17+
| unintern s == u -> True
18+
| otherwise -> any go ts
19+
ProdTy ts -> any go ts
20+
SymDictTy _ x -> go x
21+
ArrowTy ts x -> any go ts || go x
22+
VectorTy x -> go x
23+
ListTy x -> go x
24+
_ -> False
25+
where
26+
go = packedOccurs v
27+
28+
type TyMap = M.Map String ([Ty0] -> Ty0)
29+
-- type params -> type in terms of params -> args -> substituted type
30+
mkPolyNames :: [TyVar] -> Ty0 -> [Ty0] -> Ty0
31+
mkPolyNames params paramty args =
32+
substTyVar (M.fromList $ zip params args) paramty
33+
34+
elimProgram :: Prog0 -> Prog0
35+
elimProgram prog =
36+
Prog
37+
{ mainExp = (elimE connames tynames (ddefs prog) *** elimTy tynames) <$> mainExp prog
38+
, fundefs = fdefs
39+
, ddefs = tys
40+
}
41+
where
42+
(newtys, tys) = M.partition (\x -> case dataCons x of
43+
[(_, [(_, t)])] -> not $ packedOccurs (tyName x) t
44+
_ -> False
45+
) (ddefs prog)
46+
tynames =
47+
M.mapKeys (\(Var x) -> unintern x)
48+
$ M.map (mkPolyNames . tyArgs <*> snd . head . snd . head . dataCons) newtys
49+
connames = S.fromList $ fst . head . dataCons <$> M.elems newtys
50+
fdefs = M.map (\d -> d { funTy=elimTyScheme tynames (funTy d)
51+
, funBody=elimE connames tynames (ddefs prog) (funBody d)
52+
}) (fundefs prog)
53+
54+
elimE :: S.Set String -> TyMap -> DDefs Ty0 -> Exp0 -> Exp0
55+
elimE cns tns dds e0 = case e0 of
56+
DataConE _ty0 s [e]
57+
| S.member s cns -> f e
58+
DataConE _ty0 s es -> DataConE _ty0 s (f <$> es)
59+
VarE _ -> e0
60+
LitE _ -> e0
61+
CharE _ -> e0
62+
FloatE _ -> e0
63+
LitSymE _ -> e0
64+
AppE var ty es -> AppE var ty (f <$> es)
65+
PrimAppE p es -> PrimAppE (elimPrim tns p) (f <$> es)
66+
LetE (var, u, t, e1) e2 -> LetE (var, g <$> u, g t, f e1) (f e2)
67+
IfE e1 e2 e3 -> IfE (f e1) (f e2) (f e3)
68+
MkProdE es -> MkProdE (f <$> es)
69+
ProjE n e -> ProjE n (f e)
70+
CaseE e1 [(s, [(var, t)], e2)]
71+
| S.member s cns -> LetE (var, [], g t, f e1) (f e2)
72+
CaseE e x -> CaseE (f e) ((\(c, v, e1) -> (c, v, f e1)) <$> x)
73+
TimeIt e t b -> TimeIt (f e) (g t) b
74+
WithArenaE var e -> WithArenaE var (f e)
75+
SpawnE var ts es -> SpawnE var ts (f <$> es)
76+
77+
Ext ext -> Ext (elimExt cns tns dds ext)
78+
_ -> e0
79+
where
80+
f = elimE cns tns dds
81+
g = elimTy tns
82+
83+
elimExt :: S.Set String -> TyMap -> DDefs Ty0 -> E0Ext Ty0 Ty0 -> E0Ext Ty0 Ty0
84+
elimExt cns tns dds ext0 = case ext0 of
85+
LambdaE args applicand -> LambdaE (second g <$> args) (f applicand)
86+
FunRefE locs var -> FunRefE (g <$> locs) var
87+
PolyAppE pe1 pe2 -> PolyAppE (f pe1) (f pe2)
88+
BenchE var locs preexps bool -> BenchE var (g <$> locs) (f <$> preexps) bool
89+
ParE0 preexps -> ParE0 (f <$> preexps)
90+
PrintPacked dec preexp -> PrintPacked (g dec) (f preexp)
91+
CopyPacked dec preexp -> CopyPacked (g dec) (f preexp)
92+
TravPacked dec preexp -> TravPacked (g dec) (f preexp)
93+
L loc preexp -> L loc (f preexp)
94+
LinearExt (ReverseAppE pe1 pe2) -> LinearExt (ReverseAppE (f pe1) (f pe2))
95+
LinearExt (LseqE pe1 pe2) -> LinearExt (LseqE (f pe1) (f pe2))
96+
LinearExt (AliasE pe) -> LinearExt (AliasE (f pe))
97+
LinearExt (ToLinearE pe) -> LinearExt (ToLinearE (f pe))
98+
where
99+
f = elimE cns tns dds
100+
g = elimTy tns
101+
102+
elimPrim :: TyMap -> Prim Ty0 -> Prim Ty0
103+
elimPrim tns p0 = case p0 of
104+
ErrorP s t -> ErrorP s (f t)
105+
DictInsertP t -> DictInsertP (f t)
106+
DictLookupP t -> DictLookupP (f t)
107+
DictEmptyP t -> DictEmptyP (f t)
108+
DictHasKeyP t -> DictHasKeyP (f t)
109+
PDictAllocP t1 t2 -> PDictAllocP (f t1) (f t2)
110+
PDictInsertP t1 t2 -> PDictInsertP (f t1) (f t2)
111+
PDictLookupP t1 t2 -> PDictLookupP (f t1) (f t2)
112+
PDictHasKeyP t1 t2 -> PDictHasKeyP (f t1) (f t2)
113+
PDictForkP t1 t2 -> PDictForkP (f t1) (f t2)
114+
PDictJoinP t1 t2 -> PDictJoinP (f t1) (f t2)
115+
LLAllocP t -> LLAllocP (f t)
116+
LLIsEmptyP t -> LLIsEmptyP (f t)
117+
LLConsP t -> LLConsP (f t)
118+
LLHeadP t -> LLHeadP (f t)
119+
LLTailP t -> LLTailP (f t)
120+
LLFreeP t -> LLFreeP (f t)
121+
LLCopyP t -> LLCopyP (f t)
122+
VAllocP t -> VAllocP (f t)
123+
VFreeP t -> VFreeP (f t)
124+
VFree2P t -> VFree2P (f t)
125+
VLengthP t -> VLengthP (f t)
126+
VNthP t -> VNthP (f t)
127+
VSliceP t -> VSliceP (f t)
128+
InplaceVUpdateP t -> InplaceVUpdateP (f t)
129+
VConcatP t -> VConcatP (f t)
130+
VSortP t -> VSortP (f t)
131+
InplaceVSortP t -> InplaceVSortP (f t)
132+
VMergeP t -> VMergeP (f t)
133+
ReadPackedFile ms s mVar t -> ReadPackedFile ms s mVar (f t)
134+
WritePackedFile s t -> WritePackedFile s (f t)
135+
ReadArrayFile m t -> ReadArrayFile m (f t)
136+
_ -> p0
137+
where
138+
f = elimTy tns
139+
140+
elimTyScheme :: TyMap -> TyScheme -> TyScheme
141+
elimTyScheme tns (ForAll tvs t) = ForAll tvs (elimTy tns t)
142+
143+
elimTy :: TyMap -> Ty0 -> Ty0
144+
elimTy tns t0 = case t0 of
145+
PackedTy s args ->
146+
maybe (PackedTy s (f <$> args)) (f . ($ f <$> args)) (M.lookup s tns)
147+
ProdTy ts -> ProdTy (f <$> ts)
148+
SymDictTy varMaybe t -> SymDictTy varMaybe (f t)
149+
ArrowTy ts t -> ArrowTy (f <$> ts) (f t)
150+
VectorTy t -> VectorTy (f t)
151+
PDictTy tK tV -> PDictTy (f tK) (f tV)
152+
ListTy t -> ListTy (f t)
153+
_ -> t0
154+
where
155+
f = elimTy tns

‎gibbon-compiler/src/Gibbon/L0/Specialize2.hs‎

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -588,7 +588,10 @@ collectMonoObls ddefs env2 toplevel ex =
588588
LambdaE args bod -> do
589589
bod' <- collectMonoObls ddefs (extendsVEnv (M.fromList args) env2) toplevel bod
590590
pure $ Ext $ LambdaE args bod'
591-
PolyAppE{} -> error ("collectMonoObls: TODO, "++ sdoc ext)
591+
PolyAppE op arg -> do
592+
op' <- go op
593+
arg' <- go arg
594+
pure $ Ext $ PolyAppE op' arg'
592595
FunRefE tyapps f ->
593596
case tyapps of
594597
[] -> pure $ Ext $ FunRefE [] f
@@ -712,7 +715,10 @@ monoLambdas ex =
712715
TimeIt e ty b -> (\e' -> TimeIt e' ty b) <$> go e
713716
WithArenaE v e -> (\e' -> WithArenaE v e') <$> go e
714717
Ext (LambdaE{}) -> error $ "monoLambdas: Encountered a LambdaE outside a let binding. In\n" ++ sdoc ex
715-
Ext (PolyAppE{}) -> error $ "monoLambdas: TODO: " ++ sdoc ex
718+
Ext (PolyAppE op args) -> do
719+
op' <- go op
720+
args' <- go args
721+
pure $ Ext $ PolyAppE op' args'
716722
Ext (FunRefE{}) -> pure ex
717723
Ext (BenchE{}) -> pure ex
718724
Ext (ParE0 ls) -> Ext <$> ParE0 <$> mapM monoLambdas ls

‎gibbon-compiler/src/Gibbon/L0/Syntax.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import Gibbon.Language hiding (UrTy(..))
2828

2929
--------------------------------------------------------------------------------
3030

31+
-- In L0, type information may be held in locations, as locations don't exist
3132
type Exp0 = PreExp E0Ext Ty0 Ty0
3233
type DDefs0 = DDefs Ty0
3334
type DDef0 = DDef Ty0
@@ -41,6 +42,7 @@ type Prog0 = Prog Exp0
4142
data E0Ext loc dec =
4243
LambdaE [(Var,dec)] -- Variable tagged with type
4344
(PreExp E0Ext loc dec)
45+
-- unused for much of L0, may be due to a bug
4446
| PolyAppE (PreExp E0Ext loc dec) -- Operator
4547
(PreExp E0Ext loc dec) -- Operand
4648
| FunRefE [loc] Var -- Reference to a function (toplevel or lambda),

‎gibbon-compiler/src/Gibbon/L0/Typecheck.hs‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -675,7 +675,16 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$>
675675
(s4, bod_ty, bod_tc) <- tcExp ddefs s3 venv' fenv bound_tyvars is_main bod
676676
return (s4, zonkTy s4 (ArrowTy freshs bod_ty),
677677
Ext (LambdaE (map (\(v,ty) -> (v, zonkTy s4 ty)) args) (zonkExp s4 bod_tc)))
678-
Ext (PolyAppE{}) -> err $ text "TODO" <+> exp_doc
678+
679+
Ext (PolyAppE op arg) -> do
680+
(s1, t1, op_tc) <- go op
681+
(s2, t2, arg_tc) <- tcExp ddefs s1 venv fenv bound_tyvars is_main arg
682+
fresh_out <- newMetaTy
683+
let fresh_arrow = ArrowTy [t2] fresh_out
684+
s3 <- unify op t1 fresh_arrow
685+
let s4 = s2 <> s3
686+
pure (s4, zonkTy s4 fresh_out,
687+
Ext (PolyAppE (zonkExp s4 op_tc) (zonkExp s4 arg_tc)))
679688

680689
Ext (FunRefE tyapps f) -> do
681690
(_metas, ty) <-

0 commit comments

Comments
 (0)