Eta expand constructors before floating

This commit is contained in:
Dan Doel 2020-06-18 16:44:53 -04:00
parent b96badda2e
commit bac5ff1042
3 changed files with 33 additions and 0 deletions

View File

@ -41,6 +41,7 @@ module Unison.Runtime.ANF
, POp(..) , POp(..)
, IOp(..) , IOp(..)
, close , close
, constructorEta
, float , float
, lamLift , lamLift
, ANormalBF(..) , ANormalBF(..)
@ -232,6 +233,29 @@ deannotate = ABT.visitPure $ \case
lamLift :: (Var v, Monoid a) => Term v a -> Term v a lamLift :: (Var v, Monoid a) => Term v a -> Term v a
lamLift = float . close Set.empty . deannotate lamLift = float . close Set.empty . deannotate
constructorEta
:: (Var v, Monoid a)
=> Map (Reference,Int) Int -> Term v a -> Term v a
constructorEta dat = ABT.visitPure $ \case
Apps' f@(Constructor' r t) args -> eta r t f args
Apps' f@(Request' r t) args -> eta r t f args
f@(Constructor' r t) -> eta r t f []
f@(Request' r t) -> eta r t f []
_ -> Nothing
where
frsh avoid _ =
let v = Var.freshIn avoid $ typed Var.Eta
in (Set.insert v avoid, v)
eta r t f args
| Just n <- Map.lookup (r,t) dat
, vs <- snd . mapAccumL frsh fvs $ drop (length args) [1..n]
, nargs <- var mempty <$> vs
= Just . lam' mempty vs . apps' f $ args' ++ nargs
| otherwise = Just (apps' f args')
where
fvs = foldMap freeVars args
args' = constructorEta dat <$> args
optimize :: forall a v . (Semigroup a, Var v) => Term v a -> Term v a optimize :: forall a v . (Semigroup a, Var v) => Term v a -> Term v a
optimize t = go t where optimize t = go t where
ann = ABT.annotation ann = ABT.annotation

View File

@ -51,6 +51,11 @@ data EvalCtx v
, backrefTm :: EnumMap Word64 (Term v) , backrefTm :: EnumMap Word64 (Term v)
} }
uncurryDspec :: DataSpec -> Map.Map (Reference,Int) Int
uncurryDspec = Map.fromList . concatMap f . Map.toList
where
f (r,l) = zipWith (\n c -> ((r,n),c)) [0..] $ either id id l
numberLetRec :: Word64 -> Term v -> EnumMap Word64 (Term v) numberLetRec :: Word64 -> Term v -> EnumMap Word64 (Term v)
numberLetRec frsh (Tm.LetRecNamed' bs e) numberLetRec frsh (Tm.LetRecNamed' bs e)
= mapFromList . zip [frsh..] $ e : map snd bs = mapFromList . zip [frsh..] $ e : map snd bs
@ -150,6 +155,7 @@ compileTerm w tm ctx
. superNormalize (ref $ refTm ctx) (ref $ refTy ctx) . superNormalize (ref $ refTm ctx) (ref $ refTy ctx)
. lamLift . lamLift
. splitPatterns (dspec ctx) . splitPatterns (dspec ctx)
. constructorEta (uncurryDspec $ dspec ctx)
$ tm $ tm
where where
frsh = freshTm ctx frsh = freshTm ctx

View File

@ -52,6 +52,7 @@ rawName typ = case typ of
Inference TypeConstructorArg -> "𝕦" Inference TypeConstructorArg -> "𝕦"
MissingResult -> "_" MissingResult -> "_"
Blank -> "_" Blank -> "_"
Eta -> "_eta"
ANFBlank -> "_anf" ANFBlank -> "_anf"
Float -> "_float" Float -> "_float"
Pattern -> "_pattern" Pattern -> "_pattern"
@ -104,6 +105,8 @@ data Type
-- > 1 + 1 -- > 1 + 1
-- has kind "" -- has kind ""
| UnnamedWatch WatchKind Text -- guid | UnnamedWatch WatchKind Text -- guid
-- An unnamed variable for constructor eta expansion
| Eta
-- An unnamed variable introduced by ANF transformation -- An unnamed variable introduced by ANF transformation
| ANFBlank | ANFBlank
-- An unnamed variable for a floated lambda -- An unnamed variable for a floated lambda