├── .gitignore ├── Name.hs ├── Core ├── FreeVars.hs ├── Renaming.hs └── Syntax.hs ├── Evaluator ├── Renaming.hs ├── Syntax.hs ├── FreeVars.hs └── Evaluate.hs ├── LICENSE ├── Renaming.hs ├── IdSupply.hs ├── Utilities.hs └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # OS stuff 2 | .DS_Store 3 | 4 | # Build artifacts 5 | *.hi 6 | *.o 7 | dist/ 8 | .dist-scion/ 9 | -------------------------------------------------------------------------------- /Name.hs: -------------------------------------------------------------------------------- 1 | module Name ( 2 | Name(name_string), name, 3 | freshName, freshNames 4 | ) where 5 | 6 | import Utilities 7 | 8 | import Data.Function 9 | import Data.List 10 | import Data.Ord 11 | 12 | 13 | data Name = Name { 14 | name_string :: String, 15 | name_id :: Maybe Id 16 | } 17 | 18 | instance Show Name where 19 | show = show . pPrint 20 | 21 | instance Eq Name where 22 | (==) = (==) `on` name_key 23 | 24 | instance Ord Name where 25 | compare = comparing name_key 26 | 27 | instance Pretty Name where 28 | pPrintPrec level _ n = text (escape $ name_string n) <> maybe empty (\i -> char '_' <> text (show i)) (name_id n) 29 | where escape | level == haskellLevel = concatMap $ \c -> if c == '$' then "" else [c] 30 | | otherwise = id 31 | 32 | name_key :: Name -> Either String Id 33 | name_key n = maybe (Left $ name_string n) Right (name_id n) 34 | 35 | name :: String -> Name 36 | name s = Name s Nothing 37 | 38 | freshName :: IdSupply -> String -> (IdSupply, Name) 39 | freshName ids s = second (Name s . Just) $ stepIdSupply ids 40 | 41 | freshNames :: IdSupply -> [String] -> (IdSupply, [Name]) 42 | freshNames = mapAccumL freshName 43 | -------------------------------------------------------------------------------- /Core/FreeVars.hs: -------------------------------------------------------------------------------- 1 | module Core.FreeVars ( 2 | FreeVars, 3 | termFreeVars, altConFreeVars, altFreeVars, altsFreeVars, valueFreeVars 4 | ) where 5 | 6 | import Core.Syntax 7 | 8 | import qualified Data.Set as S 9 | 10 | 11 | type FreeVars = S.Set Var 12 | 13 | deleteList :: Ord a => [a] -> S.Set a -> S.Set a 14 | deleteList = flip $ foldr S.delete 15 | 16 | termFreeVars :: Term -> FreeVars 17 | termFreeVars (Var x) = S.singleton x 18 | termFreeVars (Value v) = valueFreeVars v 19 | termFreeVars (App e x) = S.insert x $ termFreeVars e 20 | termFreeVars (PrimOp _ xs) = S.fromList xs 21 | termFreeVars (Case x alts) = S.insert x $ altsFreeVars alts 22 | termFreeVars (LetRec xes e) = deleteList xs $ S.unions (map termFreeVars es) `S.union` termFreeVars e 23 | where (xs, es) = unzip xes 24 | 25 | altConFreeVars :: AltCon -> FreeVars -> FreeVars 26 | altConFreeVars (DataAlt _ xs) = deleteList xs 27 | altConFreeVars (LiteralAlt _) = id 28 | 29 | altFreeVars :: Alt -> FreeVars 30 | altFreeVars (altcon, e) = altConFreeVars altcon $ termFreeVars e 31 | 32 | altsFreeVars :: [Alt] -> FreeVars 33 | altsFreeVars = S.unions . map altFreeVars 34 | 35 | valueFreeVars :: Value -> FreeVars 36 | valueFreeVars (Lambda x e) = S.delete x $ termFreeVars e 37 | valueFreeVars (Data _ xs) = S.fromList xs 38 | valueFreeVars (Literal _) = S.empty 39 | -------------------------------------------------------------------------------- /Evaluator/Renaming.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Evaluator.Renaming where 3 | 4 | import Evaluator.Syntax 5 | 6 | import Renaming 7 | import Utilities 8 | 9 | import Data.List 10 | 11 | 12 | renameIn :: (IdSupply -> Renaming -> a -> a) -> IdSupply -> In a -> a 13 | renameIn f ids (rn, x) = f ids rn x 14 | 15 | renameInRenaming :: Renaming -> In a -> In a 16 | renameInRenaming rn_by (rn, x) = (renameRenaming rn_by rn, x) 17 | 18 | renameInVar :: Renaming -> InVar -> InVar 19 | renameInVar rn in_x = InVar (invar in_x) (safeRename "renameInVar" rn (outvar in_x)) 20 | 21 | renameInVarBinder :: IdSupply -> Renaming -> InVar -> (IdSupply, Renaming, InVar) 22 | renameInVarBinder ids rn in_x = (ids', rn', InVar (invar in_x) outvar') 23 | where (ids', rn', outvar') = renameBinder ids rn (outvar in_x) 24 | 25 | renameInVarBinders :: IdSupply -> Renaming -> [InVar] -> (IdSupply, Renaming, [InVar]) 26 | renameInVarBinders ids rn xs = reassociate $ mapAccumL ((associate .) . uncurry renameInVarBinder) (ids, rn) xs 27 | where associate (ids, rn, x) = ((ids, rn), x) 28 | reassociate ((ids, rn), xs) = (ids, rn, xs) 29 | 30 | renameQARenaming :: Renaming -> QA -> QA -- TODO: refactor QA as (In QA) and hence avoid this function? 31 | renameQARenaming rn (Question in_x) = Question (renameInVar rn in_x) 32 | renameQARenaming rn (Answer in_v) = Answer (renameInRenaming rn in_v) 33 | -------------------------------------------------------------------------------- /Evaluator/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Evaluator.Syntax where 2 | 3 | import Core.Syntax 4 | 5 | import Renaming 6 | import Utilities 7 | 8 | import Data.Function 9 | 10 | 11 | type In a = (Renaming, a) 12 | type Out a = a 13 | 14 | 15 | -- | Special representation of (In Var) so we can use it as a key in a Map. 16 | -- 17 | -- TODO: we don't actually compare by the invar (this is necessary because e.g. several 18 | -- different invars could be renamed to the same outvar, and we want the evaluator to 19 | -- be able to inline the corresponding bind!) so we could probably move the invar elsewhere. 20 | data InVar = InVar { invar :: Var, outvar :: Out Var } 21 | 22 | instance Eq InVar where 23 | (==) = (==) `on` outvar 24 | 25 | instance Ord InVar where 26 | compare = compare `on` outvar 27 | 28 | mkInVar :: Renaming -> Var -> InVar 29 | mkInVar = curry toInVar 30 | 31 | toInVar :: In Var -> InVar 32 | toInVar (rn, x) = InVar x (safeRename "toInVar" rn x) 33 | 34 | fromInVar :: InVar -> In Var 35 | fromInVar (InVar x x') = (insertRenaming x x' emptyRenaming, x) 36 | 37 | 38 | data Event = Push EvaluationContextFrame 39 | | Allocate [(InVar, In Term)] 40 | 41 | data QA = Question InVar 42 | | Answer (In Value) 43 | 44 | type Chain = Train Event (IdSupply, QA) 45 | 46 | data EvaluationContextFrame = Apply InVar 47 | | Scrutinise (In [Alt]) 48 | | PrimApply PrimOp [In Value] [InVar] 49 | | Update InVar 50 | -------------------------------------------------------------------------------- /Evaluator/FreeVars.hs: -------------------------------------------------------------------------------- 1 | module Evaluator.FreeVars ( 2 | renamingFreeVars, renamingFreeInVars, 3 | inFreeVars, inFreeInVars, 4 | qaFreeVars, evaluationContextFrameFreeVars 5 | ) where 6 | 7 | import Evaluator.Syntax 8 | 9 | import Core.FreeVars 10 | import Core.Syntax 11 | 12 | import Renaming 13 | 14 | import qualified Data.Set as S 15 | 16 | 17 | type FreeInVars = S.Set InVar 18 | 19 | renamingFreeVars :: Renaming -> FreeVars -> FreeVars 20 | renamingFreeVars rn fvs = S.map (rename rn) fvs 21 | 22 | renamingFreeInVars :: Renaming -> FreeVars -> FreeInVars 23 | renamingFreeInVars rn fvs = S.map (mkInVar rn) fvs 24 | 25 | inFreeVars :: (a -> FreeVars) -> In a -> FreeVars 26 | inFreeVars thing_fvs (rn, thing) = renamingFreeVars rn (thing_fvs thing) 27 | 28 | inFreeInVars :: (a -> FreeVars) -> In a -> FreeInVars 29 | inFreeInVars thing_fvs (rn, thing) = renamingFreeInVars rn (thing_fvs thing) 30 | 31 | qaFreeVars :: QA -> FreeVars 32 | qaFreeVars (Question in_x) = S.singleton (outvar in_x) 33 | qaFreeVars (Answer in_v) = inFreeVars valueFreeVars in_v 34 | 35 | evaluationContextFrameFreeVars :: EvaluationContextFrame -> (S.Set Var, FreeVars) 36 | evaluationContextFrameFreeVars kf = case kf of 37 | Apply in_x -> (S.empty, S.singleton (outvar in_x)) 38 | Scrutinise in_alts -> (S.empty, inFreeVars altsFreeVars in_alts) 39 | PrimApply _ in_vs in_xs -> (S.empty, S.unions (map (inFreeVars valueFreeVars) in_vs) `S.union` S.fromList (map outvar in_xs)) 40 | Update in_x -> (S.singleton (outvar in_x), S.empty) 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Max Bolingbroke 2010. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Max Bolingbroke nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Core/Renaming.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | module Core.Renaming ( 3 | renameValue, 4 | renameTerm, 5 | renameAlt, renameAltCon, renameAlts, 6 | ) where 7 | 8 | import Core.Syntax 9 | 10 | import Renaming 11 | import Utilities 12 | 13 | 14 | type In a = a 15 | type Out a = a 16 | 17 | renameValue :: IdSupply -> Renaming -> In Value -> Out Value 18 | renameValue ids rn v = case v of 19 | Lambda x e -> Lambda x' (renameTerm ids' rn' e) 20 | where (ids', rn', x') = renameBinder ids rn x 21 | Data dc xs -> Data dc (map (rename rn) xs) 22 | Literal l -> Literal l 23 | 24 | renameTerm :: IdSupply -> Renaming -> In Term -> Out Term 25 | renameTerm ids rn e = case e of 26 | Var x -> Var (safeRename "renameTerm" rn x) 27 | Value v -> Value (renameValue ids rn v) 28 | App e1 x2 -> App (renameTerm ids rn e1) (rename rn x2) 29 | PrimOp pop xs -> PrimOp pop (map (rename rn) xs) 30 | Case x alts -> Case (rename rn x) (renameAlts ids rn alts) 31 | LetRec (unzip -> (xs, es)) e -> LetRec (zipWith (\x' e -> (x', renameTerm ids' rn' e)) xs' es) (renameTerm ids' rn' e) 32 | where (ids', rn', xs') = renameBinders ids rn xs 33 | 34 | renameAlt :: IdSupply -> Renaming -> In Alt -> Out Alt 35 | renameAlt ids rn (alt_con, alt_e) = (alt_con', renameTerm ids' rn' alt_e) 36 | where (ids', rn', alt_con') = renameAltCon ids rn alt_con 37 | 38 | renameAltCon :: IdSupply -> Renaming -> In AltCon -> (IdSupply, Renaming, Out AltCon) 39 | renameAltCon ids rn_alt alt_con = case alt_con of 40 | LiteralAlt _ -> (ids, rn_alt, alt_con) 41 | DataAlt alt_dc alt_xs -> third3 (DataAlt alt_dc) $ renameBinders ids rn_alt alt_xs 42 | 43 | renameAlts :: IdSupply -> Renaming -> In [Alt] -> Out [Alt] 44 | renameAlts ids rn = map (renameAlt ids rn) 45 | -------------------------------------------------------------------------------- /Evaluator/Evaluate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, TupleSections #-} 2 | module Evaluator.Evaluate where 3 | 4 | import Evaluator.Syntax 5 | 6 | import Core.Syntax 7 | 8 | import Renaming 9 | import Utilities 10 | 11 | 12 | var :: IdSupply -> InVar -> Chain 13 | var ids in_x = Caboose (ids, Question in_x) 14 | 15 | eval :: IdSupply -> In Term -> Chain 16 | eval ids (rn, Var x) = var ids (mkInVar rn x) 17 | eval ids (rn, Value v) = Caboose (ids, Answer (rn, v)) 18 | eval ids (rn, App e1 x2) = Push (Apply (mkInVar rn x2)) `Wagon` eval ids (rn, e1) 19 | eval ids (rn, PrimOp pop (x:xs)) = Push (PrimApply pop [] (map (mkInVar rn) xs)) `Wagon` var ids (mkInVar rn x) 20 | eval ids (rn, Case x alts) = Push (Scrutinise (rn, alts)) `Wagon` var ids (mkInVar rn x) 21 | eval ids (rn, LetRec (unzip -> (xs, es)) e) 22 | = Allocate (map (mkInVar rn') xs `zip` map (rn',) es) `Wagon` eval ids' (rn', e) 23 | where (ids', rn', _xs') = renameBinders ids rn xs 24 | 25 | resumeEvaluationContextFrame :: IdSupply -> EvaluationContextFrame -> In Value -> Chain 26 | resumeEvaluationContextFrame ids (Apply in_x2) in_v = apply ids in_v in_x2 27 | resumeEvaluationContextFrame ids (Scrutinise in_alts) in_v = scrutinise ids in_v in_alts 28 | resumeEvaluationContextFrame ids (PrimApply pop in_vs in_xs) in_v = primop ids pop in_vs in_v in_xs 29 | resumeEvaluationContextFrame ids (Update in_x) in_v = update ids in_x in_v 30 | 31 | apply :: IdSupply -> In Value -> InVar -> Chain 32 | apply ids (rn, Lambda x e_body) in_x2 = eval ids (insertRenaming x (outvar in_x2) rn, e_body) 33 | 34 | scrutinise :: IdSupply -> In Value -> In [Alt] -> Chain 35 | scrutinise ids (_, Literal l) (rn_alts, alts) = eval ids (head [(rn_alts, alt_e) | (LiteralAlt alt_l, alt_e) <- alts, alt_l == l]) 36 | scrutinise ids (rn_v, Data dc xs) (rn_alts, alts) = eval ids (head [(insertRenamings (alt_xs `zip` map (rename rn_v) xs) rn_alts, alt_e) | (DataAlt alt_dc alt_xs, alt_e) <- alts, alt_dc == dc]) 37 | 38 | primop :: IdSupply -> PrimOp -> [In Value] -> In Value -> [InVar] -> Chain 39 | primop ids pop [(_, Literal l1)] (_, Literal l2) [] = Caboose (ids, Answer (emptyRenaming, Literal (f pop l1 l2))) 40 | where f pop = case pop of Add -> (+); Subtract -> (-); Multiply -> (*); Divide -> div 41 | primop ids pop in_vs in_v (in_x:in_xs) = Push (PrimApply pop (in_vs ++ [in_v]) in_xs) `Wagon` var ids in_x 42 | 43 | update :: IdSupply -> InVar -> In Value -> Chain 44 | update ids in_x in_v = Allocate [(in_x, second Value in_v)] `Wagon` Caboose (ids, Answer in_v) 45 | -------------------------------------------------------------------------------- /Renaming.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | module Renaming ( 3 | Renaming, 4 | emptyRenaming, mkRenaming, mkIdentityRenaming, 5 | insertRenaming, insertRenamings, 6 | rename, rename_maybe, safeRename, unrename, 7 | renameBinder, renameBinders, 8 | renameRenaming 9 | ) where 10 | 11 | import Name 12 | import Utilities 13 | 14 | import qualified Data.Map as M 15 | import Data.List 16 | 17 | 18 | type In a = a 19 | type Out a = a 20 | 21 | 22 | newtype Renaming = Renaming { unRenaming :: M.Map (In Name) (Out Name) } 23 | 24 | instance Pretty Renaming where 25 | pPrintPrec level _ rn = vcat [ pPrintPrec level 0 x <+> text "|->" <+> pPrintPrec level 0 x' 26 | | (x, x') <- M.toList (unRenaming rn)] 27 | 28 | 29 | emptyRenaming :: Renaming 30 | emptyRenaming = Renaming M.empty 31 | 32 | mkRenaming :: [(Name, Name)] -> Renaming 33 | mkRenaming = Renaming . M.fromList 34 | 35 | mkIdentityRenaming :: [Name] -> Renaming 36 | mkIdentityRenaming = mkRenaming . map (id &&& id) 37 | 38 | insertRenaming :: In Name -> Out Name -> Renaming -> Renaming 39 | insertRenaming n n' = Renaming . M.insert n n' . unRenaming 40 | 41 | insertRenamings :: [(In Name, Out Name)] -> Renaming -> Renaming 42 | insertRenamings = flip $ foldr (uncurry insertRenaming) 43 | 44 | rename :: Renaming -> In Name -> Out Name 45 | rename = safeRename' Nothing 46 | 47 | safeRename :: String -> Renaming -> In Name -> Out Name 48 | safeRename = safeRename' . Just 49 | 50 | safeRename' :: Maybe String -> Renaming -> In Name -> Out Name 51 | safeRename' mb_stk rn n | Just n' <- rename_maybe rn n = n' 52 | | otherwise = error $ show (text "Name" <+> pPrint n <+> text "out of scope" <+> maybe empty (\stk -> text "in" <+> text stk) mb_stk <> text "! Renaming:" $$ pPrint rn) 53 | 54 | rename_maybe :: Renaming -> In Name -> Maybe (Out Name) 55 | rename_maybe rn n = M.lookup n (unRenaming rn) 56 | 57 | unrename :: Renaming -> Out Name -> [In Name] 58 | unrename rn n' = [m | (m, m') <- M.toList (unRenaming rn), m' == n'] 59 | 60 | renameBinder :: IdSupply -> Renaming -> In Name -> (IdSupply, Renaming, Out Name) 61 | renameBinder ids rn n = (ids', insertRenaming n n' rn, n') 62 | where (ids', n') = freshName ids (name_string n) 63 | 64 | renameBinders :: IdSupply -> Renaming -> [In Name] -> (IdSupply, Renaming, [Out Name]) 65 | renameBinders ids rn = reassociate . mapAccumL ((associate .) . uncurry renameBinder) (ids, rn) 66 | where associate (ids, rn, n) = ((ids, rn), n) 67 | reassociate ((ids, rn), ns) = (ids, rn, ns) 68 | 69 | -- NB: throws away something from the Renaming being renamed if it is not in the domain of rn_by. 70 | -- This is useful behaviour for the term normalisation logic in the supercompiler, because the 71 | -- "normalising" renaming will only contain entries for actual free variables, but the "internal" 72 | -- renamings (e.g. those in the Heaps' In Terms') may contain many more entries. 73 | renameRenaming :: Renaming -> Renaming -> Renaming 74 | renameRenaming rn_by = Renaming . M.mapMaybe (rename_maybe rn_by) . unRenaming 75 | -------------------------------------------------------------------------------- /IdSupply.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | 3 | -- | This module provides splittable supplies for unique identifiers. 4 | -- The main idea gows back to L. Augustsson, M. Rittri, and D. Synek 5 | -- and is described in their paper 'On generating unique names' 6 | -- (Journal of Functional Programming 4(1), 1994. pp. 117-123). The 7 | -- implementation at hand is taken from the GHC sources and includes 8 | -- bit fiddling to allow multiple supplies that generate unique 9 | -- identifiers by prepending a character given at initialization. 10 | -- 11 | -- This is a custom version of uniqueid-0.1.1 to resolve some bugs I 12 | -- found in it. 13 | module IdSupply ( 14 | Id, hashedId, IdSupply, initIdSupply, splitIdSupplyL, splitIdSupply, idFromSupply 15 | ) where 16 | 17 | import GHC.Exts 18 | -- MCB: change to uniqueid-0.1.1: use GHC.IO rather than GHC.IOBase 19 | import GHC.IO ( unsafeDupableInterleaveIO ) 20 | 21 | import Data.IORef 22 | import System.IO.Unsafe ( unsafePerformIO ) 23 | 24 | 25 | -- | Unique identifiers are of type 'Id' and can be hashed to an 'Int' 26 | -- usning the function 'hashedId'. 27 | newtype Id = Id { hashedId :: Int } 28 | 29 | -- | Supplies for unique identifiers are of type 'IdSupply' and can be 30 | -- split into two new supplies or yield a unique identifier. 31 | data IdSupply = IdSupply Int# IdSupply IdSupply 32 | 33 | -- | Generates a new supply of unique identifiers. The given character 34 | -- is prepended to generated numbers. 35 | initIdSupply :: Char -> IO IdSupply 36 | initIdSupply (C# c) = 37 | case uncheckedIShiftL# (ord# c) (unboxedInt 24) of 38 | mask -> 39 | let mkSupply = 40 | unsafeDupableInterleaveIO ( 41 | nextInt >>= \ (I# u) -> 42 | mkSupply >>= \ l -> 43 | mkSupply >>= \ r -> 44 | return (IdSupply (word2Int# (or# (int2Word# mask) (int2Word# u))) l r)) 45 | in mkSupply 46 | 47 | -- | Splits a supply of unique identifiers to yield two of them. 48 | splitIdSupply :: IdSupply -> (IdSupply,IdSupply) 49 | splitIdSupply (IdSupply _ l r) = (l,r) 50 | 51 | -- | Splits a supply of unique identifiers to yield an infinite list of them. 52 | splitIdSupplyL :: IdSupply -> [IdSupply] 53 | splitIdSupplyL ids = ids1 : splitIdSupplyL ids2 54 | where 55 | (ids1, ids2) = splitIdSupply ids 56 | 57 | -- | Yields the unique identifier from a supply. 58 | idFromSupply :: IdSupply -> Id 59 | idFromSupply (IdSupply n _ _) = Id (I# n) 60 | 61 | instance Eq Id where Id (I# x) == Id (I# y) = x ==# y 62 | 63 | instance Ord Id 64 | where 65 | Id (I# x) < Id (I# y) = x <# y 66 | Id (I# x) <= Id (I# y) = x <=# y 67 | 68 | compare (Id (I# x)) (Id (I# y)) = 69 | if x ==# y then EQ else if x <# y then LT else GT 70 | 71 | instance Show Id 72 | where 73 | showsPrec _ i s = case unpackId i of (c,n) -> c:show n++s 74 | 75 | 76 | 77 | 78 | unboxedInt :: Int -> Int# 79 | unboxedInt (I# x) = x 80 | 81 | -- MCB: change to uniqueid-0.1.1: ensure that the global IORef is not inlined! 82 | {-# NOINLINE global #-} 83 | global :: IORef Int 84 | global = unsafePerformIO (newIORef 0) 85 | 86 | -- MCB: change to uniqueid-0.1.1: prevent race conditions 87 | nextInt :: IO Int 88 | nextInt = atomicModifyIORef global (\n -> (succ n, succ n)) 89 | 90 | unpackId :: Id -> (Char,Int) 91 | unpackId (Id (I# i)) = 92 | let tag = C# (chr# (uncheckedIShiftRL# i (unboxedInt 24))) 93 | num = I# (word2Int# (and# (int2Word# i) 94 | (int2Word# (unboxedInt 16777215)))) 95 | in (tag, num) -------------------------------------------------------------------------------- /Core/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards, ViewPatterns #-} 2 | module Core.Syntax where 3 | 4 | import Name 5 | import Utilities 6 | 7 | import Data.List 8 | import Data.Maybe 9 | 10 | 11 | type Var = Name 12 | 13 | type DataCon = String 14 | 15 | data PrimOp = Add | Subtract | Multiply | Divide 16 | deriving (Eq, Show) 17 | 18 | data AltCon = DataAlt DataCon [Var] | LiteralAlt Literal 19 | deriving (Eq, Show) 20 | 21 | type Literal = Int 22 | 23 | data Term = Var Var | Value Value | App Term Var | PrimOp PrimOp [Var] | Case Var [Alt] | LetRec [(Var, Term)] Term 24 | deriving (Eq, Show) 25 | 26 | type Alt = (AltCon, Term) 27 | 28 | data Value = Lambda Var Term | Data DataCon [Var] | Literal Literal 29 | deriving (Eq, Show) 30 | 31 | instance Pretty PrimOp where 32 | pPrint Add = text "(+)" 33 | pPrint Subtract = text "(-)" 34 | pPrint Multiply = text "(*)" 35 | pPrint Divide = text "(/)" 36 | 37 | instance Pretty AltCon where 38 | pPrintPrec level prec altcon = case altcon of 39 | DataAlt dc xs -> prettyParen (prec >= appPrec) $ text dc <+> hsep (map (pPrintPrec level appPrec) xs) 40 | LiteralAlt l -> int l 41 | 42 | instance Pretty Term where 43 | pPrintPrec level prec e = case e of 44 | LetRec xes e -> pPrintPrecLetRec level prec xes e 45 | Var x -> pPrintPrec level prec x 46 | Value v -> pPrintPrec level prec v 47 | App e1 x2 -> pPrintPrecApp level prec e1 x2 48 | PrimOp pop xs -> pPrintPrecPrimOp level prec pop xs 49 | Case x alts | level == haskellLevel, null alts -> text "undefined" 50 | | otherwise -> pPrintPrecCase level prec x alts 51 | 52 | pPrintPrecApp :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> b -> Doc 53 | pPrintPrecApp level prec e1 e2 = prettyParen (prec >= appPrec) $ pPrintPrec level opPrec e1 <+> pPrintPrec level appPrec e2 54 | 55 | pPrintPrecPrimOp :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> [b] -> Doc 56 | pPrintPrecPrimOp level prec pop xs = pPrintPrecApps level prec pop xs 57 | 58 | pPrintPrecCase :: (Pretty a, Pretty b, Pretty c) => PrettyLevel -> Rational -> a -> [(b, c)] -> Doc 59 | pPrintPrecCase level prec e alts = prettyParen (prec > noPrec) $ hang (text "case" <+> pPrintPrec level noPrec e <+> text "of") 2 $ vcat (map (pPrintPrecAlt level noPrec) alts) 60 | 61 | pPrintPrecAlt :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> (a, b) -> Doc 62 | pPrintPrecAlt level _ (alt_con, alt_e) = hang (pPrintPrec level noPrec alt_con <+> text "->") 2 (pPrintPrec level noPrec alt_e) 63 | 64 | pPrintPrecLetRec :: (Pretty a, Pretty b, Pretty c) => PrettyLevel -> Rational -> [(a, b)] -> c -> Doc 65 | pPrintPrecLetRec level prec xes e 66 | | [] <- xes = pPrintPrec level prec e 67 | | otherwise = prettyParen (prec > noPrec) $ hang (if level == haskellLevel then text "let" else text "letrec") 2 (vcat [pPrintPrec level noPrec x <+> text "=" <+> pPrintPrec level noPrec e | (x, e) <- xes]) $$ text "in" <+> pPrintPrec level noPrec e 68 | 69 | instance Pretty Value where 70 | pPrintPrec level prec v = case v of 71 | Lambda x e -> pPrintPrecLam level prec (x:xs) e' 72 | where (xs, e') = collectLambdas e 73 | Data dc xs -> pPrintPrecApps level prec (PrettyFunction $ \_ _ -> text dc) xs 74 | Literal l -> int l 75 | 76 | pPrintPrecLam :: Pretty a => PrettyLevel -> Rational -> [Var] -> a -> Doc 77 | pPrintPrecLam level prec xs e = prettyParen (prec > noPrec) $ text "\\" <> hsep [pPrintPrec level appPrec y | y <- xs] <+> text "->" <+> pPrintPrec level noPrec e 78 | 79 | pPrintPrecApps :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> [b] -> Doc 80 | pPrintPrecApps level prec e1 es2 = prettyParen (not (null es2) && prec >= appPrec) $ pPrintPrec level opPrec e1 <+> hsep (map (pPrintPrec level appPrec) es2) 81 | 82 | 83 | isVar :: Term -> Bool 84 | isVar (Var _) = True 85 | isVar _ = False 86 | 87 | termVar_maybe :: Term -> Maybe Var 88 | termVar_maybe (Var x) = Just x 89 | termVar_maybe _ = Nothing 90 | 91 | termValue_maybe :: Term -> Maybe Value 92 | termValue_maybe (Value v) = Just v 93 | termValue_maybe _ = Nothing 94 | 95 | letRec :: [(Var, Term)] -> Term -> Term 96 | letRec [] e = e 97 | letRec xes e = LetRec xes e 98 | 99 | lambdas :: [Var] -> Term -> Term 100 | lambdas = flip $ foldr ((Value .) . Lambda) 101 | 102 | apps :: Term -> [Var] -> Term 103 | apps = foldl App 104 | 105 | collectLambdas :: Term -> ([Var], Term) 106 | collectLambdas (Value (Lambda x e)) = first (x:) $ collectLambdas e 107 | collectLambdas e = ([], e) 108 | 109 | freshFloatVar :: IdSupply -> String -> Term -> (IdSupply, Maybe (Name, Term), Name) 110 | freshFloatVar ids s (Var x) = (ids, Nothing, x) 111 | freshFloatVar ids s e = (ids', Just (y, e), y) 112 | where (ids', y) = freshName ids s 113 | 114 | freshFloatVars :: IdSupply -> String -> [Term] -> (IdSupply, [(Name, Term)], [Name]) 115 | freshFloatVars ids s es = reassociate $ mapAccumL (\ids -> associate . freshFloatVar ids s) ids es 116 | where reassociate (ids, unzip -> (mb_floats, xs)) = (ids, catMaybes mb_floats, xs) 117 | associate (ids, mb_float, x) = (ids, (mb_float, x)) -------------------------------------------------------------------------------- /Utilities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, PatternGuards #-} 2 | module Utilities ( 3 | module IdSupply, 4 | module Utilities, 5 | 6 | module Control.Arrow, 7 | module Control.Exception, 8 | module Control.Monad, 9 | 10 | module Debug.Trace, 11 | 12 | module Text.PrettyPrint.HughesPJClass 13 | ) where 14 | 15 | import IdSupply 16 | 17 | import Control.Arrow (first, second, (***), (&&&)) 18 | import Control.Exception (assert) 19 | import Control.Monad 20 | 21 | import qualified Data.Set as S 22 | 23 | import Debug.Trace 24 | 25 | import Text.PrettyPrint.HughesPJClass hiding (render) 26 | 27 | import System.IO.Unsafe (unsafePerformIO) 28 | 29 | 30 | instance Pretty a => Pretty (S.Set a) where 31 | pPrint xs = char '{' <> hsep (punctuate (char ',') (map pPrint $ S.toList xs)) <> char '}' 32 | 33 | 34 | {-# NOINLINE reduceIdSupply #-} 35 | reduceIdSupply :: IdSupply 36 | reduceIdSupply = unsafePerformIO $ initIdSupply 'u' 37 | 38 | {-# NOINLINE normaliseIdSupply #-} 39 | normaliseIdSupply :: IdSupply 40 | normaliseIdSupply = unsafePerformIO $ initIdSupply 'n' 41 | 42 | stepIdSupply :: IdSupply -> (IdSupply, Id) 43 | stepIdSupply = second idFromSupply . splitIdSupply 44 | 45 | 46 | data Train a b = Wagon a (Train a b) 47 | | Caboose b 48 | 49 | 50 | appPrec, opPrec, noPrec :: Rational 51 | appPrec = 2 -- Argument of a function application 52 | opPrec = 1 -- Argument of an infix operator 53 | noPrec = 0 -- Others 54 | 55 | normalLevel, haskellLevel :: PrettyLevel 56 | normalLevel = PrettyLevel 0 57 | haskellLevel = PrettyLevel 1 58 | 59 | 60 | angles, coangles :: Doc -> Doc 61 | angles d = char '<' <> d <> char '>' 62 | coangles d = char '>' <> d <> char '<' 63 | 64 | 65 | pPrintPrec' :: Pretty a => a -> PrettyLevel -> Rational -> Doc 66 | pPrintPrec' x level prec = pPrintPrec level prec x 67 | 68 | -- NB: this render function is exported instead of the one from the library 69 | render :: Doc -> String 70 | render = renderStyle (style { lineLength = 120 }) 71 | 72 | pPrintRender :: Pretty a => a -> String 73 | pPrintRender = render . pPrint 74 | 75 | 76 | traceRender :: Pretty a => a -> b -> b 77 | traceRender x = trace (pPrintRender x) 78 | 79 | 80 | removeOnes :: [a] -> [[a]] 81 | removeOnes [] = [] 82 | removeOnes (x:xs) = xs : map (x:) (removeOnes xs) 83 | 84 | 85 | instance (Pretty a, Pretty b, Pretty c, Pretty d, 86 | Pretty e, Pretty f, Pretty g, Pretty h, 87 | Pretty i, Pretty j, Pretty k, Pretty l, 88 | Pretty m, Pretty n, Pretty o) => Pretty (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where 89 | pPrint (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) 90 | = pPrintTuple [pPrint a, pPrint b, pPrint c, pPrint d, 91 | pPrint e, pPrint f, pPrint g, pPrint h, 92 | pPrint i, pPrint j, pPrint k, pPrint l, 93 | pPrint m, pPrint n, pPrint o] 94 | 95 | pPrintTuple :: [Doc] -> Doc 96 | pPrintTuple ds = parens $ fsep $ punctuate comma ds 97 | 98 | 99 | newtype PrettyFunction = PrettyFunction (PrettyLevel -> Rational -> Doc) 100 | 101 | instance Pretty PrettyFunction where 102 | pPrintPrec level prec (PrettyFunction f) = f level prec 103 | 104 | asPrettyFunction :: Pretty a => a -> PrettyFunction 105 | asPrettyFunction = PrettyFunction . pPrintPrec' 106 | 107 | 108 | fst3 :: (a, b, c) -> a 109 | fst3 (a, _, _) = a 110 | 111 | snd3 :: (a, b, c) -> b 112 | snd3 (_, b, _) = b 113 | 114 | thd3 :: (a, b, c) -> c 115 | thd3 (_, _, c) = c 116 | 117 | first3 :: (a -> d) -> (a, b, c) -> (d, b, c) 118 | first3 f (a, b, c) = (f a, b, c) 119 | 120 | second3 :: (b -> d) -> (a, b, c) -> (a, d, c) 121 | second3 f (a, b, c) = (a, f b, c) 122 | 123 | third3 :: (c -> d) -> (a, b, c) -> (a, b, d) 124 | third3 f (a, b, c) = (a, b, f c) 125 | 126 | second4 :: (b -> e) -> (a, b, c, d) -> (a, e, c, d) 127 | second4 f (a, b, c, d) = (a, f b, c, d) 128 | 129 | third4 :: (c -> e) -> (a, b, c, d) -> (a, b, e, d) 130 | third4 f (a, b, c, d) = (a, b, f c, d) 131 | 132 | secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) 133 | secondM f (a, b) = liftM (a,) $ f b 134 | 135 | 136 | uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 137 | uncurry3 f (a, b, c) = f a b c 138 | 139 | 140 | splitBy :: [b] -> [a] -> ([a], [a]) 141 | splitBy [] xs = ([], xs) 142 | splitBy (_:ys) (x:xs) = first (x:) $ splitBy ys xs 143 | 144 | splitManyBy :: [[b]] -> [a] -> [[a]] 145 | splitManyBy [] xs = [xs] 146 | splitManyBy (ys:yss) xs = case splitBy ys xs of (xs1, xs2) -> xs1 : splitManyBy yss xs2 147 | 148 | 149 | splitAtRev :: Int -> [a] -> ([a], [a]) 150 | splitAtRev n xs = case splitAt n (reverse xs) of (xs1, xs2) -> (reverse xs2, reverse xs1) 151 | 152 | takeFirst :: (a -> Bool) -> [a] -> (Maybe a, [a]) 153 | takeFirst p = takeFirstJust (\x -> guard (p x) >> return x) 154 | 155 | takeFirstJust :: (a -> Maybe b) -> [a] -> (Maybe b, [a]) 156 | takeFirstJust _ [] = (Nothing, []) 157 | takeFirstJust p (x:xs) 158 | | Just y <- p x = (Just y, xs) 159 | | otherwise = second (x:) $ takeFirstJust p xs 160 | 161 | expectJust :: String -> Maybe a -> a 162 | expectJust _ (Just x) = x 163 | expectJust s Nothing = error $ "expectJust: " ++ s 164 | 165 | safeFromLeft :: Either a b -> Maybe a 166 | safeFromLeft (Left x) = Just x 167 | safeFromLeft _ = Nothing 168 | 169 | safeHead :: [a] -> Maybe a 170 | safeHead [] = Nothing 171 | safeHead (x:_) = Just x 172 | 173 | expectHead :: String -> [a] -> a 174 | expectHead s = expectJust s . safeHead 175 | 176 | fixpoint :: Eq a => (a -> a) -> a -> a 177 | fixpoint f x 178 | | x' == x = x 179 | | otherwise = fixpoint f x' 180 | where x' = f x 181 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, PatternGuards #-} 2 | module Main (main) where 3 | 4 | import Core.FreeVars 5 | import Core.Renaming 6 | import Core.Syntax 7 | 8 | import Evaluator.Evaluate 9 | import Evaluator.Renaming 10 | import Evaluator.Syntax 11 | 12 | import Name 13 | import Renaming 14 | import Utilities 15 | 16 | import qualified Data.Set as S 17 | import qualified Data.Map as M 18 | import Data.Maybe 19 | 20 | 21 | type PureHeap = M.Map InVar (In Term) 22 | data Heap = Heap PureHeap IdSupply 23 | 24 | type EvaluationContext = [EvaluationContextFrame] 25 | 26 | 27 | evaluate :: Term -> (Heap, EvaluationContext, QA) 28 | evaluate e = f (first3 (flip Heap ids2) $ initialiseTerm ids1 (mkIdentityRenaming $ S.toList $ termFreeVars e, e)) 29 | where (ids1, ids2) = splitIdSupply reduceIdSupply 30 | f (Heap h ids, k, qa) = case qa of Answer in_v | (kf:k) <- k -> g h k (resumeEvaluationContextFrame ids kf in_v) 31 | Question in_x | Just in_e <- M.lookup in_x h -> g (M.delete in_x h) (Update in_x : k) (eval ids in_e) 32 | _ -> (Heap h ids, k, qa) 33 | 34 | g h k chain = f (followChain h k chain) 35 | 36 | initialiseTerm :: IdSupply -> In Term -> (PureHeap, EvaluationContext, QA) 37 | initialiseTerm ids e = case followChain M.empty [] (eval ids e) of (Heap h _, k, qa) -> (h, k, qa) 38 | 39 | followChain :: PureHeap -> EvaluationContext -> Chain -> (Heap, EvaluationContext, QA) 40 | followChain h k (Caboose (ids, qa)) = (Heap h ids, k, qa) 41 | followChain h k (Wagon (Allocate in_xes) chain) = followChain (h `M.union` M.fromList in_xes) k chain 42 | followChain h k (Wagon (Push kf) chain) = followChain h (kf:k) chain 43 | 44 | 45 | residualiseAll :: Heap -> EvaluationContext -> QA -> Out Term 46 | residualiseAll heap k qa = residualiseHeap heap (\ids -> residualiseEvaluationContext ids k (residualiseQA ids qa)) 47 | 48 | residualiseQA :: IdSupply -> QA -> Out Term 49 | residualiseQA _ (Question in_x) = Var (outvar in_x) 50 | residualiseQA ids (Answer in_v) = Value (renameIn renameValue ids in_v) 51 | 52 | residualiseHeap :: Heap -> (IdSupply -> ([(Out Var, Out Term)], Out Term)) -> Out Term 53 | residualiseHeap (Heap h ids) (($ ids) -> (floats, e)) = letRec ([(outvar in_x, renameIn renameTerm ids in_e) | (in_x, in_e) <- M.toList h] ++ floats) e 54 | 55 | residualiseEvaluationContext :: IdSupply -> [EvaluationContextFrame] -> Out Term -> ([(Out Var, Out Term)], Out Term) 56 | residualiseEvaluationContext _ [] e = ([], e) 57 | residualiseEvaluationContext ids (kf:k) (residualiseEvaluationContextFrame ids kf -> (floats, e)) = first (floats ++) $ residualiseEvaluationContext ids k e 58 | 59 | residualiseEvaluationContextFrame :: IdSupply -> EvaluationContextFrame -> Out Term -> ([(Out Var, Out Term)], Out Term) 60 | residualiseEvaluationContextFrame _ (Apply in_x2) e1 = ([], App e1 (outvar in_x2)) 61 | residualiseEvaluationContextFrame ids (Scrutinise in_alts) e = (maybeToList mb_float, Case x' (renameIn renameAlts ids' in_alts)) 62 | where (ids', mb_float, x') = freshFloatVar ids "scrut" e 63 | residualiseEvaluationContextFrame ids (PrimApply pop in_vs in_xs) e = (floats, PrimOp pop (ys' ++ map outvar in_xs)) 64 | where (ids', floats, ys') = freshFloatVars ids "arg" (map (Value . renameIn renameValue ids') in_vs ++ [e]) 65 | residualiseEvaluationContextFrame _ (Update in_x) e = ([(x', e)], Var x') 66 | where x' = outvar in_x 67 | 68 | 69 | main :: IO () 70 | main = do 71 | putStrLn "Input:" 72 | putStrLn $ pPrintRender e 73 | 74 | let e' = uncurry3 residualiseAll $ evaluate e 75 | putStrLn "Output:" 76 | putStrLn $ pPrintRender e' 77 | where 78 | lit = Value . Literal 79 | nilDataCon = "[]" 80 | nil = Value (Data nilDataCon []) 81 | consDataCon = "(:)" 82 | cons x xs = Value (Data consDataCon [x, xs]) 83 | 84 | list s xs = uncurry letRec $ foldr (\(hd, i) (floats, e) -> let tl = name (s ++ show i) in ((tl, e) : floats, cons hd tl)) ([], nil) (xs `zip` [0..]) 85 | 86 | trueDataCon = "True" 87 | true = Value (Data trueDataCon []) 88 | falseDataCon = "False" 89 | false = Value (Data falseDataCon []) 90 | 91 | nothingDataCon = "Nothing" 92 | nothing = Value (Data nothingDataCon []) 93 | justDataCon = "Just" 94 | just x = Value (Data justDataCon [x]) 95 | 96 | if_ x et ef = Case x [(DataAlt trueDataCon [], et), (DataAlt falseDataCon [], ef)] 97 | 98 | {- 99 | -- Simple beta-reduction 100 | (rn, [cons_wrap, y, ys]) = freshBinders emptyRenaming ["cons_wrap", "y", "ys"] 101 | e = LetRec [(cons_wrap, Value $ Lambda y $ Value $ Lambda ys $ Value (Data consDataCon [y, ys]))] $ 102 | (Case (list [Value (Literal 1)]) [(DataAlt consDataCon [y, ys], Var y)]) 103 | -} 104 | 105 | {- 106 | -- Case-of-case mediated by an update frame: a bit tricky, because we need to do a linearity check upon residualisation 107 | [unknown, x, y] = map name ["unknown", "x", "y"] 108 | e = Value $ Lambda unknown $ LetRec [(x, Case unknown [(DataAlt nilDataCon [], nil)]), 109 | (y, Case x [(DataAlt nilDataCon [], lit 10)])] $ 110 | Var y 111 | -} 112 | 113 | {- 114 | -- Checks that we are able to gain information through case scrutinisation 115 | [unknown, x] = map name ["unknown", "x"] 116 | e = Value $ Lambda unknown $ Case unknown [(DataAlt justDataCon [x], Case unknown [(DataAlt justDataCon [x], Var x)])] 117 | -} 118 | 119 | {- 120 | -- A more challenging case where we gain information by scrutinisation 121 | [unknown1, unknown2, x] = map name ["unknown1", "unknown2", "x"] 122 | e = Value $ Lambda unknown1 $ Value (Lambda unknown2 (Case unknown1 [ 123 | (DataAlt justDataCon [x], Case unknown2 [(DataAlt justDataCon [x], Var x)])])) `App` unknown1 124 | -} 125 | 126 | {- 127 | -- Primarily a test of the correctness of the renamer 128 | (rn, [cons_wrap, eat, y, ys, x, xs, zs]) = freshBinders emptyRenaming ["cons_wrap", "eat", "y", "ys", "x", "xs", "zs"] -- y_u17, zs_u17 129 | e = LetRec [(cons_wrap, Value $ Lambda y $ Value $ Lambda ys $ Value (Data consDataCon [y, ys])), 130 | (eat, Value $ Lambda zs $ Case (Var zs) [(DataAlt consDataCon [x, xs], Value (PrimOp Add []) `App` Var x `App` Case (Var xs) [(DataAlt consDataCon [x, xs], Var x)])])] $ 131 | (Var eat `App` list [Value (Literal 1), Value (Literal 2)]) 132 | -} 133 | 134 | {- 135 | -- Tests that we gain information from cases and that our "cheapification" is reasonably good 136 | [sum, xs, y, ys, ys', one, two, three] = map name ["sum", "xs", "y", "ys", "ys'", "one", "two", "three"] 137 | e = LetRec [(sum, Value $ Lambda xs $ 138 | Case xs [(DataAlt nilDataCon [], 139 | lit 0), 140 | (DataAlt consDataCon [y, ys], 141 | LetRec [(ys', Var sum `App` ys)] $ 142 | PrimOp Add [y, ys'])]), 143 | (one, lit 1), (two, lit 2), (three, lit 3)] $ 144 | (Value $ Lambda y $ Case y [(LiteralAlt 0, LetRec [(ys, list "list" [y, one, two, three])] $ 145 | Var sum `App` ys)]) 146 | -} 147 | 148 | {- 149 | -- Tests recursive functions and residualisation 150 | [sum, xs, y, ys, ys', one, two, three] = map name ["sum", "xs", "y", "ys", "ys'", "one", "two", "three"] 151 | e = LetRec [(sum, Value $ Lambda xs $ 152 | Case xs [(DataAlt nilDataCon [], 153 | lit 0), 154 | (DataAlt consDataCon [y, ys], 155 | LetRec [(ys', Var sum `App` ys)] $ 156 | PrimOp Add [y, ys'])])] $ 157 | (Value $ Lambda y $ LetRec [(one, lit 1), (two, lit 2), (three, lit 3), 158 | (ys, list "list" [y, one, two, three]] $ 159 | Var sum `App` ys) 160 | -} 161 | 162 | {- 163 | -- Tests that we pull down outer continuation frames into case branches 164 | (_rn, [cons_wrap, y, ys]) = freshBinders emptyRenaming ["cons_wrap", "y", "ys"] 165 | e = LetRec [(cons_wrap, Value $ Lambda y $ Value $ Lambda ys $ Value (Data consDataCon [y, ys]))] $ 166 | (Value $ Lambda y $ Value (PrimOp Add []) `App` Case (Var y) [(LiteralAlt 1, Var y), 167 | (LiteralAlt 2, Value (Literal 1))] `App` Value (Literal 3)) 168 | -} 169 | 170 | {- 171 | -- Tests whether we can do tupling (challenging?) 172 | [sum, length, average, a, b, v, vs, w, ws, x, xs, y, z, ys, zs] = map name ["sum", "length", "average", "a", "b", "v", "vs", "w", "ws", "x" ,"xs", "y", "z", "ys", "zs"] 173 | e = LetRec [(sum, Value $ Lambda xs $ 174 | Case xs [(DataAlt nilDataCon [], 175 | lit 0), 176 | (DataAlt consDataCon [y, ys], 177 | LetRec [(zs, Var sum `App` ys)] $ 178 | PrimOp Add [y, zs])]), 179 | (length, Value $ Lambda xs $ 180 | Case xs [(DataAlt nilDataCon [], 181 | lit 0), 182 | (DataAlt consDataCon [w, ws], 183 | LetRec [(v, lit 1), 184 | (vs, Var length `App` ws)] $ 185 | PrimOp Add [v, vs])]), 186 | (average, Value $ Lambda xs $ LetRec [(a, Var sum `App` xs), 187 | (b, Var length `App` xs)] $ 188 | PrimOp Divide [a, b])] $ 189 | (Value $ Lambda ys $ Var average `App` ys) 190 | -} 191 | 192 | {--} 193 | -- Tests simple function specialisation: map (1+) 194 | [mymap, f, xs, y, ys, z, zs] = map name ["map", "f", "xs", "y", "ys", "z", "zs"] 195 | e = LetRec [(mymap, Value $ Lambda f $ Value $ Lambda xs $ 196 | Case xs [(DataAlt nilDataCon [], 197 | nil), 198 | (DataAlt consDataCon [y, ys], 199 | LetRec [(z, Var f `App` y), 200 | (zs, Var mymap `App` f `App` ys)] $ 201 | cons z zs)]), 202 | (f, Value $ Lambda y $ LetRec [(z, Value (Literal 1))] $ 203 | PrimOp Add [z, y])] $ 204 | (Value $ Lambda ys $ Var mymap `App` f `App` ys) 205 | {--} 206 | 207 | {- 208 | (_rn, [cons_wrap, map, f, xs, y, ys, z, zs]) = freshBinders emptyRenaming ["cons_wrap", "map", "f", "xs", "y", "ys", "z", "zs"] 209 | e = LetRec [(cons_wrap, Value $ Lambda y $ Value $ Lambda ys $ Value (Data consDataCon [y, ys])), 210 | (map, Value $ Lambda f $ Value $ Lambda xs $ 211 | Case (Var xs) [(DataAlt nilDataCon [], 212 | Value (Data nilDataCon [])), 213 | (DataAlt consDataCon [z, zs], 214 | Var cons_wrap `App` (Var f `App` Var z) `App` (Var map `App` Var f `App` Var zs))])] $ 215 | (Value $ Lambda ys $ Var map `App` (Value $ Lambda y $ Value (PrimOp Add [Literal 1]) `App` Var y) `App` (Var map `App` (Value $ Lambda y $ Value (PrimOp Subtract [Literal 1]) `App` Var y) `App` Var ys)) 216 | -} 217 | 218 | {- 219 | -- This example should NOT move expensive inside the z binding during supercompilation, but ideally 220 | -- it should float it up so that we can inline the primop application into both sides of the case 221 | [expensive, unk_f, unk_w, x, y, z] = map name ["expensive", "unk_f", "unk_w", "x", "y", "z"] 222 | e = Value $ Lambda unk_f $ Value $ Lambda unk_w $ 223 | LetRec [(y, LetRec [(x, lit 2), 224 | (expensive, Var unk_f `App` x)] $ 225 | Case unk_w [(DataAlt trueDataCon [], Value (Literal 1)), 226 | (DataAlt falseDataCon [], Var expensive)]), 227 | (x, lit 10)] $ 228 | Value (Lambda z $ PrimOp Add [y, x]) 229 | -} 230 | 231 | {- 232 | -- Tests you can handle letrecs nicely 233 | [one, ones, x, xs, y, ys] = map name ["one", "ones", "x", "xs", "y", "ys"] 234 | e = LetRec [(one, lit 1), 235 | (ones, cons one ones)] $ 236 | Case ones [(DataAlt consDataCon [x, xs], Case xs [(DataAlt consDataCon [y, ys], PrimOp Add [x, y])])] 237 | -} 238 | 239 | {- 240 | -- Tests that your termination criteria works 241 | [reverse, reverse_worker, xs, acc, acc', z, zs] = map name ["reverse", "reverse_worker", "xs", "acc", "acc'", "z", "zs"] 242 | e = LetRec [(reverse_worker, Value $ Lambda xs $ Value $ Lambda acc $ 243 | Case xs [(DataAlt nilDataCon [], 244 | Var acc), 245 | (DataAlt consDataCon [z, zs], 246 | LetRec [(acc', cons z acc)] $ 247 | Var reverse_worker `App` zs `App` acc')]), 248 | (zs, nil), 249 | (reverse, Value $ Lambda xs $ Var reverse_worker `App` xs `App` zs)] $ 250 | (Var reverse) 251 | -} 252 | --------------------------------------------------------------------------------