diff --git a/DDC/Core/Transform/ANormal.hs b/DDC/Core/Transform/ANormal.hs --- a/DDC/Core/Transform/ANormal.hs +++ b/DDC/Core/Transform/ANormal.hs @@ -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 diff --git a/DDC/Core/Transform/AnonymizeX.hs b/DDC/Core/Transform/AnonymizeX.hs --- a/DDC/Core/Transform/AnonymizeX.hs +++ b/DDC/Core/Transform/AnonymizeX.hs @@ -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 diff --git a/DDC/Type/Transform/AnonymizeT.hs b/DDC/Type/Transform/AnonymizeT.hs --- a/DDC/Type/Transform/AnonymizeT.hs +++ b/DDC/Type/Transform/AnonymizeT.hs @@ -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') diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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: diff --git a/ddc-core-simpl.cabal b/ddc-core-simpl.cabal --- a/ddc-core-simpl.cabal +++ b/ddc-core-simpl.cabal @@ -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 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