ddc-core-simpl 0.2.0.1 → 0.2.1.1
raw patch · 5 files changed
+137/−76 lines, 5 filesdep ~ddc-basedep ~ddc-corePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ddc-base, ddc-core
API changes (from Hackage documentation)
Files
- DDC/Core/Transform/ANormal.hs +118/−61
- DDC/Core/Transform/AnonymizeX.hs +2/−5
- DDC/Type/Transform/AnonymizeT.hs +1/−4
- LICENSE +11/−1
- ddc-core-simpl.cabal +5/−5
DDC/Core/Transform/ANormal.hs view
@@ -5,7 +5,7 @@ import DDC.Core.Exp import qualified DDC.Type.Exp as T import qualified DDC.Type.Compounds as T-import qualified DDC.Type.Universe as U+import qualified DDC.Core.Transform.AnonymizeX as A import qualified DDC.Core.Transform.LiftX as L import qualified Data.Map as Map@@ -13,29 +13,33 @@ -- **** Recording arities of known values -- So we can try to create apps to fully apply --- I did have these as Maybe Int, but I think for our purposes 0==Nothing is fine+-- | Arities of known bound variables.+-- We need to track everything even if it's not a function to keep indices correct.+-- Just use zero for unknown/irrelevant type Arities n = (Map.Map n Int, [Int]) +-- | Empty arities context arEmpty :: Ord n => Arities n arEmpty = (Map.empty, []) +-- | Extend map with multiple bindings and their arities arExtends :: Ord n => Arities n -> [(Bind n, Int)] -> Arities n arExtends arity exts = foldl go arity exts where go (named,anon) (BNone _t, _) = (named,anon) go (named,anon) (BAnon _t, a) = (named, a:anon) go (named,anon) (BName n _t, a) = (Map.insert n a named, anon) +-- | Look up a binder's arity arGet :: Ord n => Arities n -> Bound n -> Int--- TODO unsafe ix arGet (_named, anon) (UIx ix _) = anon !! ix arGet (named, _anon) (UName n _) = named Map.! n--- Get a primitive's arity from its type.--- Assuming all the primitives defer effects until fully applied.+-- Get a primitive's arity from its type arGet (_named,_anon) (UPrim _ t) = arityOfType t -- **** Finding arities of expressions etc --- Count all the arrows, ignoring any effects+-- | Count all the arrows and foralls, ignoring any effects+-- We can be sure that primitives don't effect until they're fully applied arityOfType :: Ord n => Type n -> Int arityOfType (T.TForall _ t) = 1 + arityOfType t@@ -43,53 +47,59 @@ = let (args, _) = T.takeTFunArgResult t in length args +-- | Find arity of an expression. Count lambdas, use type for primitives arityOfExp :: Ord n => Exp a n -> Int-arityOfExp (XLam _ b e)- -- only count data binders- | isBinderData b- = 1 + arityOfExp e+-- Counting all binders, because they all correspond to XApps. arityOfExp (XLam _ _ e) = 1 + arityOfExp e arityOfExp (XLAM _ _ e) = 1 + arityOfExp e+-- Find primitive's constructor's arities from type,+-- we might need to do this for user defined constructors too. arityOfExp (XCon _ (UPrim _ t)) = arityOfType t+-- Anything else we'll need to apply one at a time arityOfExp _ = 0 -isBinderData :: Ord n => Bind n -> Bool-isBinderData b | Just U.UniverseData <- U.universeFromType1 (T.typeOfBind b)- = True-isBinderData _ = False---- We don't know anything about their values,--- but we need to record them as 0 anyway (shadowing, de bruijn)+-- | Retrieve binders from case pattern, so we can extend the arity context.+-- We don't know anything about their values, so record as 0. aritiesOfPat :: Ord n => Pat n -> [(Bind n, Int)] aritiesOfPat PDefault = [] aritiesOfPat (PData _b bs) = zip bs (repeat 0) -- **** Actually converting to a-normal form-anormal :: Ord n => Arities n -> Exp a n -> [Exp a n] -> Exp a n-anormal ar (XApp _ lhs rhs) args- = -- normalise applicand and record arguments- let args' = anormal ar rhs [] : args in++-- | Recursively transform expression into a-normal+anormal :: Ord n+ => Arities n -- ^ environment, arities of bound variables+ -> Exp a n -- ^ expression to transform+ -> [(Exp a n,a)]-- ^ arguments being applied to current expression+ -> Exp a n++-- Application: just record argument and descend into function+anormal ar (XApp a lhs rhs) args+ = -- normalise rhs and add to arguments+ let args' = (anormal ar rhs [], a) : args in -- descend into lhs, remembering all args anormal ar lhs args' +-- Anything other than application: if we're applied to arguments add bindings,+-- otherwise just recurse. anormal ar x args = let x' = go x in- -- if there are no args, we're done case args of+ -- if there are no args, we're done [] -> x'- _ -> -- there are arguments. we must apply them.- makeLets ar x' args+ -- there are arguments. we must apply them.+ _ -> flattenLets $ makeLets ar x' args where -- helper for descent down ars e = anormal (arExtends ar ars) e [] -- we know x isn't an app.- go (XApp{}) = error "ANormal.anormal: impossible XApp!"+ go (XApp{}) = error "DDC.Core.Transform.ANormal.anormal: impossible XApp!" -- leafy ones go (XVar{}) = x@@ -97,6 +107,7 @@ go (XType{}) = x go (XWitness{}) = x + -- lambdas go (XLAM a b e) = XLAM a b (down [(b,0)] e) go (XLam a b e) =@@ -122,75 +133,121 @@ let ars = zip bs (repeat 0) in XLet a (LLetRegion b bs) (down ars re) - -- I don't think a withregion should ever show up...+ -- withregion: I don't think this should ever show up. go (XLet a (LWithRegion b) re) = XLet a (LWithRegion b) (down [] re) + -- case go (XCase a e alts) = let e' = down [] e in let alts' = map (\(AAlt pat ae) -> AAlt pat (down (aritiesOfPat pat) ae)) alts in XCase a e' alts' + -- cast go (XCast a c e) = XCast a c (down [] e) --- | (under development)+-- | Convert an expression into a-normal form anormalise :: Ord n => Exp a n -> Exp a n anormalise x = anormal arEmpty x [] --- | Check if an expression needs a binding, or if it's simple enough to just be applied+-- | Check if an expression needs a binding, or if it's simple enough to be applied as-is isNormal :: Ord n => Exp a n -> Bool+-- Trivial expressions isNormal (XVar{}) = True isNormal (XCon{}) = True isNormal (XType{}) = True isNormal (XWitness{}) = True+-- Casts are ignored by code generator, so we can leave them in if their subexpression is normal isNormal (XCast _ _ x) = isNormal x isNormal _ = False -makeLets ar f0 args = go 0 (findArity f0) (f0:args) []+-- | Create lets for any non-trivial arguments+makeLets :: Ord n+ => Arities n -- ^ environment, arities of bound variables+ -> Exp a n -- ^ function+ -> [(Exp a n,a)]-- ^ arguments being applied to current expression+ -> Exp a n+makeLets _ f0 [] = f0+makeLets ar f0 args@((_,annot):_) = go 0 (findArity f0) ((f0,annot):args) [] where tBot = T.tBot T.kData - -- sending arity of f to this is a hack because we should really be building up ar ctx?- go i _arf [] acc = mkApps i 0 acc- -- f is fully applied, and we *do* have arguments left to add- go i arf (x:xs) acc | length acc > arf- = XLet (annotOf x) (LLet LetStrict (BAnon tBot) (mkApps i 0 acc))- (go i 1 (x:xs) [XVar (annotOf x) $ UIx 0 tBot])+ -- out of arguments, create XApps out of leftovers+ go i _arf [] acc = mkApps i 0 acc+ -- f is fully applied and we have arguments left to add:+ -- create let for intermediate result+ go i arf ((x,a):xs) acc | length acc > arf+ = XLet a (LLet LetStrict (BAnon tBot) (mkApps i 0 acc))+ (go i 1 ((x,a):xs) [(XVar a $ UIx 0 tBot,a)]) -- application to variable, don't bother binding- go i arf (x:xs) acc | isNormal x- = go i arf xs (x:acc)- -- create binding- go i arf (x:xs) acc- = XLet (annotOf x) (LLet LetStrict (BAnon tBot) (L.liftX i x))- (go (i+1) arf xs (x:acc))+ go i arf ((x,a):xs) acc | isNormal x+ = go i arf xs ((x,a):acc)+ -- non-trivial argument, create binding+ go i arf ((x,a):xs) acc+ = XLet a (LLet LetStrict (BAnon tBot) (L.liftX i x))+ (go (i+1) arf xs ((x,a):acc)) + -- fold list into applications+ -- can't create empty app mkApps _ _ []- = error "ANormal.makeLets.mkApps: impossible empty list"- mkApps l _ [x] | isNormal x+ = error "DDC.Core.Transform.ANormal.makeLets.mkApps: impossible empty list"++ -- single element - this is the function+ mkApps l _ [(x,_)] | isNormal x = L.liftX l x- mkApps _ i [x]- = XVar (annotOf x) $ UIx i tBot+ mkApps _ i [(_,a)]+ = XVar a $ UIx i tBot - mkApps l i (x:xs) | isNormal x- = XApp (annotOf x) (mkApps l i xs) (L.liftX l x)- mkApps l i (x:xs)- = XApp (annotOf x) (mkApps l (i+1) xs) (XVar (annotOf x) $ UIx i tBot)+ -- apply this argument and recurse+ mkApps l i ((x,a):xs) | isNormal x+ = XApp a (mkApps l i xs) (L.liftX l x)+ mkApps l i ((_,a):xs)+ = XApp a (mkApps l (i+1) xs) (XVar a $ UIx i tBot) findArity (XVar _ b) = max (arGet ar b) 1 findArity x = max (arityOfExp x) 1 --- does this exist elsewhere? ought it?-annotOf :: Exp a n -> a-annotOf (XVar a _) = a-annotOf (XCon a _) = a-annotOf (XApp a _ _) = a-annotOf (XLAM a _ _) = a-annotOf (XLam a _ _) = a-annotOf (XLet a _ _) = a-annotOf (XCase a _ _) = a-annotOf (XCast a _ _) = a-annotOf (XType{}) = error "DDC.Core.Transform.ANormal.annotOf: XType"-annotOf (XWitness{}) = error "DDC.Core.Transform.ANormal.annotOf: XWitness"+-- | Perform let-floating on strict non-recursive lets+-- Only does the top level, to clean up the ones directly produced by makeLets.+-- let b1 = (let b2 = def2 in x2)+-- in x1+-- ==>+-- let b2 = def2+-- in let b1 = x2+-- in x1+flattenLets :: Ord n+ => Exp a n+ -> Exp a n +-- We only do this if b2 is anonymous (ones generated by makeLets are).+-- If we tried to wrap x1 in b2 when b2's name is already used,+-- we'd be in trouble.+flattenLets+ (XLet a1+ (LLet LetStrict b1+ (XLet a2 (LLet LetStrict b2@(BAnon _) def2) x2))+ x1)+ = -- If b1 is anon, we don't want to lift references to it+ let liftDepth = case b1 of { BAnon _ -> 1; _ -> 0 } in+ let x1' = L.liftAtDepthX 1 liftDepth x1 in+ XLet a2 (LLet LetStrict b2 def2) $+ flattenLets $ XLet a1 (LLet LetStrict b1 x2) x1'++-- Same as above but b2 isn't anonymous - anonymize inner let & re-flatten.+flattenLets+ (XLet a1+ (LLet LetStrict b1 inner@(XLet _ (LLet LetStrict _ _) _))+ x1)+ = flattenLets $+ XLet a1+ (LLet LetStrict b1 (A.anonymizeX inner))+ x1++-- Any let, its bound expression doesn't contain a strict non-recursive let so just flatten the body+flattenLets (XLet a1 llet1 x1)+ = XLet a1 llet1 (flattenLets x1)++-- Anything else we can ignore. We don't need to recurse, because this is always called immediately after makeLets.+flattenLets x = x
DDC/Core/Transform/AnonymizeX.hs view
@@ -125,10 +125,7 @@ pushAnonymizeBindX kstack tstack b = let b' = anonymizeWithX kstack tstack b t' = typeOfBind b'- tstack' = case b' of- BName{} -> b' : tstack- BAnon{} -> b' : tstack- _ -> tstack+ tstack' = b' : tstack in (tstack', BAnon t') @@ -157,8 +154,8 @@ = case lts of LLet mode b x -> let mode' = anonymizeWithX kstack tstack mode+ x' = anonymizeWithX kstack tstack x (tstack', b') = pushAnonymizeBindX kstack tstack b- x' = anonymizeWithX kstack tstack' x in (kstack, tstack', LLet mode' b' x') LRec bxs
DDC/Type/Transform/AnonymizeT.hs view
@@ -70,9 +70,6 @@ pushAnonymizeBindT :: Ord n => [Bind n] -> Bind n -> ([Bind n], Bind n) pushAnonymizeBindT kstack b = let t' = typeOfBind b- kstack' = case b of- BName{} -> b : kstack- BAnon{} -> b : kstack- _ -> kstack+ kstack' = b : kstack in (kstack', BAnon t')
LICENSE view
@@ -1,7 +1,8 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyright (c) 2008-2011 Benjamin Lippmeier+Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force+All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal@@ -12,6 +13,15 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++-------------------------------------------------------------------------------+Under Australian law copyright is free and automatic.+By contributing to DDC authors grant all rights they have regarding their+contributions to the other members of the Disciplined Disciple Compiler Strike+Force, past, present and future, as well as placing their contributions under+the above license.++Use "darcs show authors" to get a list of Strike Force members. -------------------------------------------------------------------------------- Redistributions of libraries in ./external are governed by their own licenses:
ddc-core-simpl.cabal view
@@ -1,9 +1,9 @@ Name: ddc-core-simpl-Version: 0.2.0.1+Version: 0.2.1.1 License: MIT License-file: LICENSE-Author: Ben Lippmeier-Maintainer: benl@ouroborus.net+Author: The Disciplined Disciple Compiler Strike Force+Maintainer: Ben Lippmeier <benl@ouroborus.net> Build-Type: Simple Cabal-Version: >=1.6 Stability: experimental@@ -20,8 +20,8 @@ array >= 0.3 && < 0.5, transformers == 0.2.*, mtl == 2.0.*,- ddc-base == 0.2.0.*,- ddc-core == 0.2.0.*+ ddc-base == 0.2.1.*,+ ddc-core == 0.2.1.* Exposed-modules: DDC.Core.Transform.AnonymizeX