mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-22 07:48:10 +03:00
Eta expand constructors before floating
This commit is contained in:
parent
b96badda2e
commit
bac5ff1042
@ -41,6 +41,7 @@ module Unison.Runtime.ANF
|
||||
, POp(..)
|
||||
, IOp(..)
|
||||
, close
|
||||
, constructorEta
|
||||
, float
|
||||
, lamLift
|
||||
, ANormalBF(..)
|
||||
@ -232,6 +233,29 @@ deannotate = ABT.visitPure $ \case
|
||||
lamLift :: (Var v, Monoid a) => Term v a -> Term v a
|
||||
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 t = go t where
|
||||
ann = ABT.annotation
|
||||
|
@ -51,6 +51,11 @@ data EvalCtx 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 frsh (Tm.LetRecNamed' bs e)
|
||||
= mapFromList . zip [frsh..] $ e : map snd bs
|
||||
@ -150,6 +155,7 @@ compileTerm w tm ctx
|
||||
. superNormalize (ref $ refTm ctx) (ref $ refTy ctx)
|
||||
. lamLift
|
||||
. splitPatterns (dspec ctx)
|
||||
. constructorEta (uncurryDspec $ dspec ctx)
|
||||
$ tm
|
||||
where
|
||||
frsh = freshTm ctx
|
||||
|
@ -52,6 +52,7 @@ rawName typ = case typ of
|
||||
Inference TypeConstructorArg -> "𝕦"
|
||||
MissingResult -> "_"
|
||||
Blank -> "_"
|
||||
Eta -> "_eta"
|
||||
ANFBlank -> "_anf"
|
||||
Float -> "_float"
|
||||
Pattern -> "_pattern"
|
||||
@ -104,6 +105,8 @@ data Type
|
||||
-- > 1 + 1
|
||||
-- has kind ""
|
||||
| UnnamedWatch WatchKind Text -- guid
|
||||
-- An unnamed variable for constructor eta expansion
|
||||
| Eta
|
||||
-- An unnamed variable introduced by ANF transformation
|
||||
| ANFBlank
|
||||
-- An unnamed variable for a floated lambda
|
||||
|
Loading…
Reference in New Issue
Block a user