From 3075aadf3dd717d0e8dfe0cbcb92961c6a2a6760 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Mon, 8 Apr 2024 12:52:31 -0600 Subject: [PATCH] rotten codebase --- README.org | 4 ++++ src/Core/Syntax.hs | 1 + src/Core/Utils.hs | 33 ++++++----------------------- src/Core2Core.hs | 51 +++++++++++++++++++++++++------------------- src/Rlp2Core.hs | 53 ++++++++++++++++++++++++++++++++++++++++------ 5 files changed, 88 insertions(+), 54 deletions(-) diff --git a/README.org b/README.org index 322d92c..8384fcf 100644 --- a/README.org +++ b/README.org @@ -164,6 +164,10 @@ Available debug flags include: id : ∀ ($a0 : Type). $a0 -> $a0 = ; #end_src + + +** TODO Core.Utils.freeVariables does not handle let-bindings :bug: + * Releases ** +December Release+ diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 2e7741b..f5f1faf 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -263,6 +263,7 @@ type ScDef' = ScDef Name lambdaLifting :: Iso (ScDef b) (ScDef b') (b, Expr b) (b', Expr b') lambdaLifting = iso sa bt where + sa (ScDef n [] e) = (n, e) where sa (ScDef n as e) = (n, e') where e' = Lam as e diff --git a/src/Core/Utils.hs b/src/Core/Utils.hs index 30f2c4e..d2c0e23 100644 --- a/src/Core/Utils.hs +++ b/src/Core/Utils.hs @@ -8,8 +8,8 @@ module Core.Utils ---------------------------------------------------------------------------------- import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Functor.Foldable -import Data.Set (Set) -import Data.Set qualified as S +import Data.HashSet (HashSet) +import Data.HashSet qualified as S import Core.Syntax import Control.Lens import GHC.Exts (IsList(..)) @@ -28,29 +28,10 @@ isAtomic _ = False ---------------------------------------------------------------------------------- -freeVariables :: Expr b -> Set b +freeVariables :: Expr' -> HashSet Name freeVariables = undefined - --- freeVariables :: Expr' -> Set Name --- freeVariables = cata go --- where --- go :: ExprF Name (Set Name) -> Set Name --- go (VarF k) = S.singleton k --- -- TODO: collect free vars in rhss of bs --- go (LetF _ bs e) = (e `S.union` esFree) `S.difference` ns --- where --- es = bs ^.. each . _rhs :: [Expr'] --- ns = S.fromList $ bs ^.. each . _lhs --- -- TODO: this feels a little wrong. maybe a different scheme is --- -- appropriate --- esFree = foldMap id $ freeVariables <$> es - --- go (CaseF e as) = e `S.union` asFree --- where --- -- asFree = foldMap id $ freeVariables <$> (fmap altToLam as) --- asFree = foldMap (freeVariables . altToLam) as --- -- we map alts to lambdas to avoid writing a 'freeVariablesAlt' --- altToLam (Alter _ ns e) = Lam ns e --- go (LamF bs e) = e `S.difference` (S.fromList bs) --- go e = foldMap id e +-- freeVariables = cata \case +-- VarF n -> S.singleton n +-- CaseF e as -> e <> (foldMap f as) +-- where f (AlterF _ bs e) = fold e `S.difference` S.fromList bs diff --git a/src/Core2Core.hs b/src/Core2Core.hs index 4f49281..994e665 100644 --- a/src/Core2Core.hs +++ b/src/Core2Core.hs @@ -11,8 +11,8 @@ module Core2Core ---------------------------------------------------------------------------------- import Data.Functor.Foldable import Data.Maybe (fromJust) -import Data.Set (Set) -import Data.Set qualified as S +import Data.HashSet (HashSet) +import Data.HashSet qualified as S import Data.List import Data.Foldable import Control.Monad.Writer @@ -22,6 +22,8 @@ import Data.Text qualified as T import Data.HashMap.Strict (HashMap) import Numeric (showHex) +import Misc.MonadicRecursionSchemes + import Data.Pretty import Compiler.RLPC import Control.Lens @@ -46,10 +48,14 @@ gmPrep :: Program' -> Program' gmPrep p = p & appFloater (floatNonStrictCases globals) & tagData & defineData + & etaReduce where globals = p ^.. programScDefs . each . _lhs . _1 & S.fromList +programGlobals :: Program b -> HashSet b +programGlobals = undefined + -- | Define concrete supercombinators for all datatags defined via pragmas (or -- desugaring) @@ -92,7 +98,7 @@ runFloater = flip evalStateT ns >>> runWriter -- TODO: formally define a "strict context" and reference that here -- the returned ScDefs are guaranteed to be free of non-strict cases. -floatNonStrictCases :: Set Name -> Expr' -> Floater Expr' +floatNonStrictCases :: HashSet Name -> Expr' -> Floater Expr' floatNonStrictCases g = goE where goE :: Expr' -> Floater Expr' @@ -104,24 +110,20 @@ floatNonStrictCases g = goE goE e = goC e goC :: Expr' -> Floater Expr' - -- the only truly non-trivial case: when a case expr is found in a - -- non-strict context, we float it into a supercombinator, give it a - -- name consumed from the state, record the newly created sc within the - -- Writer, and finally return an expression appropriately calling the sc - goC p@(Case e as) = do - n <- name - let (e',sc) = floatCase g n p - altBodies = (\(Alter _ _ b) -> b) <$> as - tell [sc] - goE e - traverse_ goE altBodies - pure e' - goC (App f x) = App <$> goC f <*> goC x - goC (Let r bs e) = Let r <$> bs' <*> goE e - where bs' = travBs goC bs - goC (Lit l) = pure (Lit l) - goC (Var k) = pure (Var k) - goC (Con t as) = pure (Con t as) + goC = cataM \case + -- the only truly non-trivial case: when a case expr is found in a + -- non-strict context, we float it into a supercombinator, give it a + -- name consumed from the state, record the newly created sc within the + -- Writer, and finally return an expression appropriately calling the sc + CaseF e as -> do + n <- name + let (e',sc) = floatCase g n (Case e as) + altBodies = (\(Alter _ _ b) -> b) <$> as + tell [sc] + goE e + traverse_ goE altBodies + pure e' + t -> pure $ embed t name = state (fromJust . Data.List.uncons) @@ -132,10 +134,15 @@ floatNonStrictCases g = goE -- ^ ??? what the fuck? -- ^ 24/02/22: what is this shit lol? +etaReduce :: Program' -> Program' +etaReduce = programScDefs . each %~ \case + ScDef n as (Lam bs e) -> ScDef n (as ++ bs) e + ScDef n as e -> ScDef n as e + -- when provided with a case expr, floatCase will float the case into a -- supercombinator of its free variables. the sc is returned along with an -- expression that calls the sc with the necessary arguments -floatCase :: Set Name -> Name -> Expr' -> (Expr', ScDef') +floatCase :: HashSet Name -> Name -> Expr' -> (Expr', ScDef') floatCase g n c@(Case e as) = (e', sc) where sc = ScDef n caseFrees c diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs index 72b7b32..bda1269 100644 --- a/src/Rlp2Core.hs +++ b/src/Rlp2Core.hs @@ -84,8 +84,8 @@ runNameSupply :: Text -> Eff (NameSupply ': es) a -> Eff es a runNameSupply pre = runLabeled $ evalState [ pre <> "_" <> tshow name | name <- [0..] ] where tshow = T.pack . show -single :: (Monoid s, Applicative f) => ASetter s t a (f b) -> b -> t -single l a = mempty & l .~ pure a +single :: (Monoid s) => ASetter s t a b -> b -> t +single l a = mempty & l .~ a -- the rl' program is desugared by desugaring each declaration as a separate -- program, and taking the monoidal product of the lot :3 @@ -97,16 +97,41 @@ rlpProgToCore = foldMapOf (programDecls . each) declToCore declToCore :: Rlp.Decl PsName TypedRlpExpr' -> Core.Program Var +declToCore (DataD n as ds) + = foldMap (uncurry $ conToCore t) ([0..] `zip` ds) + <> single programTyCons (H.singleton n k) + where + as' = TyVar <$> as + k = foldr (:->) t as' + t = foldl TyApp (TyCon n) as' + -- assume full eta-expansion for now declToCore (FunD b [] e) = single programScDefs $ - ScDef b' [] e' + [ScDef b' [] e'] where b' = MkVar b (typeToCore $ extract e) e' = runPureEff . runNameSupply b . cataM exprToCore . retype $ e +conToCore :: Core.Type -> Int -> DataCon PsName -> Core.Program Var +conToCore t tag (DataCon b as) + = single programScDefs [ScDef b' [] $ Con tag arity] + where + arity = lengthOf arrowStops t - 1 + b' = MkVar b t + dummyExpr :: Text -> Core.Expr b dummyExpr a = Var ("<" <> a <> ">") +stripTypes :: Core.Program Var -> Core.Program Name +stripTypes p = Core.Program + { _programTyCons = p ^. programTyCons + , _programDataTags = p ^. programDataTags + , _programScDefs = p ^. programScDefs + & each . binders %~ (\ (MkVar n _) -> n) + -- TEMP + , _programTypeSigs = mempty + } + -------------------------------------------------------------------------------- -- | convert rl' types to Core types, annotate binders, and strip excess type @@ -124,6 +149,9 @@ retype = (_extract %~ unquantify) >>> fmap typeToCore >>> cata \case t :<$ InR (LetEF r bs e) -> Finr (LetEF r _ _) + t :<$ InR (CaseEF e as) + -> _ + unquantify :: Rlp.Type b -> Rlp.Type b unquantify (ForallT _ x) = unquantify x @@ -145,15 +173,28 @@ exprToCore :: (NameSupply :> es) -> Eff es (Core.Expr Var) exprToCore (InL e) = pure . embed $ e -exprToCore (InR _) = _ -exprToCore _ = pure $ dummyExpr "expr" +exprToCore (InR e) = exprToCore' e + +exprToCore' :: (NameSupply :> es) + => Rlp.ExprF Var (Core.Expr Var) -> Eff es (Core.Expr Var) + +exprToCore' (CaseEF e as) = pure $ Case e (alterToCore <$> as) + +exprToCore' _ = pure $ dummyExpr "expr" + +alterToCore :: Rlp.Alter Var (Expr Var) -> Core.Alter Var +alterToCore (Rlp.Alter (ConP' (MkVar n _) bs) e) + = Core.Alter (AltData n) (noPatterns bs) e + +noPatterns :: [Pat b] -> [b] +noPatterns ps = ps ^.. each . singular _VarP -------------------------------------------------------------------------------- annotateVar :: Core.Type -> Core.ExprF PsName a -> Core.ExprF Var a --- fixed points: +-- fix-points: annotateVar _ (VarF n) = VarF n annotateVar _ (ConF t a) = ConF t a annotateVar _ (AppF f x) = AppF f x