├── .gitignore ├── Makefile ├── README.md ├── etc └── Obsidian │ └── README.md ├── front_end ├── directive_driven │ ├── DirectiveDriven.hs │ ├── Helpers │ │ └── Annotations.hs │ └── directive-driven.cabal └── overloading │ ├── Feldspar │ ├── Example.hs │ ├── GADT.hs │ ├── InterpGADT.hs │ └── Test.hs │ ├── MiniFeldspar.cabal │ └── OverloadingFeldspar.hs ├── install_all.sh ├── lang_features └── template_haskell │ ├── TemplateHaskell1.hs │ └── TemplateHaskell2.hs ├── middle_end ├── GADT_transforms │ ├── Mini-Accelerate.cabal │ └── src │ │ ├── AST.hs │ │ ├── Array │ │ ├── Data.hs │ │ └── Sugar.hs │ │ ├── Fusion.hs │ │ ├── Interpreter.hs │ │ ├── Pretty.hs │ │ ├── Substitution.hs │ │ ├── Test.hs │ │ └── Type.hs ├── multi-level_AST │ ├── Feldspar │ │ ├── GeneratedADT.hs │ │ ├── InterpADT.hs │ │ ├── ManualADT.hs │ │ ├── Test2.hs │ │ ├── TypeCase.hs │ │ └── TypeableMagic.hs │ └── MiniFeldspar2.cabal ├── nanopass │ ├── course_example │ │ ├── FrameworkHs │ │ │ ├── GenGrammars │ │ │ │ ├── L00VerifyScheme.hs │ │ │ │ ├── L01ParseScheme.hs │ │ │ │ ├── L02ConvertComplexDatum.hs │ │ │ │ ├── L03UncoverAssigned.hs │ │ │ │ ├── L04PurifyLetrec.hs │ │ │ │ ├── L05ConvertAssignments.hs │ │ │ │ ├── L07RemoveAnonymousLambda.hs │ │ │ │ ├── L08SanitizeBindings.hs │ │ │ │ ├── L09UncoverFree.hs │ │ │ │ ├── L10ConvertClosures.hs │ │ │ │ ├── L12UncoverWellKnown.hs │ │ │ │ ├── L15IntroduceProcedurePrimitives.hs │ │ │ │ ├── L17LiftLetrec.hs │ │ │ │ ├── L18NormalizeContext.hs │ │ │ │ ├── L19SpecifyRepresentation.hs │ │ │ │ ├── L20UncoverLocals.hs │ │ │ │ ├── L22VerifyUil.hs │ │ │ │ ├── L23RemoveComplexOpera.hs │ │ │ │ ├── L24FlattenSet.hs │ │ │ │ ├── L25ImposeCallingConventions.hs │ │ │ │ ├── L26ExposeAllocationPointer.hs │ │ │ │ ├── L27UncoverFrameConflict.hs │ │ │ │ ├── L28PreAssignFrame.hs │ │ │ │ ├── L29AssignNewFrame.hs │ │ │ │ ├── L30FinalizeFrameLocations.hs │ │ │ │ ├── L32UncoverRegisterConflict.hs │ │ │ │ ├── L33AssignRegisters.hs │ │ │ │ ├── L35DiscardCallLive.hs │ │ │ │ ├── L36FinalizeLocations.hs │ │ │ │ ├── L37ExposeFrameVar.hs │ │ │ │ ├── L38ExposeMemoryOperands.hs │ │ │ │ ├── L39ExposeBasicBlocks.hs │ │ │ │ └── L41FlattenProgram.hs │ │ │ ├── Helpers.hs │ │ │ ├── Prims.hs │ │ │ └── SExpReader │ │ │ │ ├── LispData.hs │ │ │ │ └── Parser.hs │ │ ├── grammar-list.ss │ │ └── nanopass-sample.cabal │ └── exercise │ │ ├── FrameworkHs │ │ ├── GenGrammars │ │ │ ├── MicroScheme.hs │ │ │ └── NoLets.hs │ │ ├── Helpers.hs │ │ ├── Prims.hs │ │ └── SExpReader │ │ ├── RemoveLet.hs │ │ ├── grammar-list.ss │ │ └── nanopass-exercise.cabal └── syntactic │ ├── NanoFeldspar.hs │ ├── NanoFeldsparTests.hs │ └── nanofeldspar.cabal └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | .#* 2 | dist 3 | .DS_Store 4 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | all: 5 | ./install_all.sh 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | A tour of Haskell features for DSL building 4 | =========================================== 5 | 6 | Here we give samples of different techniques and show how to use some 7 | existing libraries that are relevant to DSL construction. 8 | -------------------------------------------------------------------------------- /etc/Obsidian/README.md: -------------------------------------------------------------------------------- 1 | 2 | Obsidian 3 | ======== 4 | 5 | 6 | 7 | Key aspects of implementation 8 | ----------------------------- 9 | 10 | * Small core: The Exp and Program GADTs, the AST (or deeply embedded part) 11 | of Obsidian is relatively small. 12 | 13 | * Arrays are implemented as a library on top of deep embedding. 14 | pull arrays: 15 | data Pull s a = Pull s (W32 -> a) 16 | data Push t s a = Push s ((W32 -> a -> Program Thread ()) -> Program t ()) 17 | 18 | The shallow/deep approach. 19 | 20 | 21 | * In a sense the current approach to "how to program the hierarchy" 22 | is also just a library on top of the deep embedding. 23 | The deep embedded (Program type) is restricted to describe programs 24 | that we can compile to CUDA. But the currently used API exposed to the 25 | user can be changed if we like. 26 | 27 | * Simple (naive) monad reification (Observe structure of monad program). 28 | Bjorn & Benny reification. 29 | 30 | 31 | The thoughts behind Obsidian 32 | ---------------------------- 33 | 34 | * Started out as the question: can a lava-style of programming 35 | be applied to GPUs. 36 | 37 | Originally: Write a high-level program in lava style and 38 | automatically decompose it to fit the GPU 39 | In order to do that we must first understand how to program GPUs. So 40 | let us expose all the GPU low-level details needed for performance. 41 | (This is where we are still at). 42 | 43 | * Implementation-wise I was long reluctant to use too many "extensions" 44 | and tried to do as much as possible in as simple as possible Haskell. 45 | Over the years, even I learned (to some degree) how to use some of the 46 | fancier aspects of Haskell and they crept in. 47 | 48 | 49 | 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /front_end/directive_driven/DirectiveDriven.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | {-| 4 | 5 | One popular approach to parallelizing programs and even programming 6 | Accelerators is the "directive driven" approach embodied by OpenMP and 7 | OpenAcc. See this workshop, for example: 8 | 9 | http://www.openacc.org/WACCPD14 10 | 11 | This is a competing approach to DSLs, which instead use customized 12 | languages, rather than directive-annoted versions of general purpose 13 | languages. Or is it? Typically, only a subset of the general purpose 14 | language will run on, e.g., the GPU. Thus the same language 15 | subsetting problem arrises. 16 | 17 | In this sketch we have a peek at what the directive-driven approach 18 | may look like in Haskell. 19 | 20 | -} 21 | 22 | module Main where 23 | 24 | import Helpers.Annotations 25 | 26 | -- First we want to define a function that is usable in the permitted 27 | -- subset. Let's say, usable on GPU or on embedded platforms that 28 | -- don't allow allocation. 29 | {-# ANN foo [GPU,Embedded] #-} 30 | foo :: Double -> Double 31 | foo x = cos x + 3 * x 32 | 33 | -- Next, ideally we would like to use Template Haskell's `reify` 34 | -- feature to grab an AST representing the definition of `foo`. 35 | -- Unfortunately, this functionality is currently incomplete and only 36 | -- good for type-level introspection, not term-level. 37 | 38 | -- $(mkGPUFun 'foo) 39 | 40 | -- We do have recourse. We can instead use one of the options: 41 | 42 | -- OPTION (1): Use haskell-src-exts, which can parse whole modules, to 43 | -- read in the abstract syntax, including the definition of `foo`. 44 | 45 | -- OPTION (2): Use a GHC plugin compiler pass. It will receive the 46 | -- program's intermediate representation, which includes the source 47 | -- annotation, "ANN", above. 48 | 49 | -- OPTION (3): We can still use Template Haskell, if we put the 50 | -- definitions in question directly within a quotation. Note here 51 | -- that quotations can include entire declarations as well as 52 | -- exprressions: 53 | 54 | $(myLangDefs 55 | [d| 56 | 57 | data MyDat = MyDat Int 58 | 59 | {-# ANN z [GPU,Embedded] #-} 60 | z :: Integer 61 | z = 34 62 | 63 | |]) 64 | 65 | -- In this case the package "th-desugar" (used by singletons) may come 66 | -- in handy to reduce the number of constructs we need to deal with. 67 | 68 | main = return () 69 | -------------------------------------------------------------------------------- /front_end/directive_driven/Helpers/Annotations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | -- | 5 | 6 | module Helpers.Annotations where 7 | 8 | import Data.Data 9 | import Language.Haskell.TH 10 | 11 | data Where = CPU | GPU | Embedded 12 | deriving (Show, Eq, Read, Ord, Enum, Bounded, Typeable, Data) 13 | 14 | 15 | mkGPUFun :: Name -> ExpQ 16 | mkGPUFun _ = 17 | [| error "This stub is not implemented for the demo." |] 18 | 19 | myLangDefs :: Q [Dec] -> Q [Dec] 20 | myLangDefs x = do x' <- x 21 | runIO $ do putStrLn "\nmyLangDefs (stub): would make definitions out of these:" 22 | putStrLn $ pprint x' ++ "\n" 23 | return x' 24 | -------------------------------------------------------------------------------- /front_end/directive_driven/directive-driven.cabal: -------------------------------------------------------------------------------- 1 | -- Initial directive-driven.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: directive-driven 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | -- license: 9 | -- license-file: LICENSE 10 | author: Ryan Newton 11 | maintainer: rrnewton@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable directive-driven 19 | main-is: DirectiveDriven.hs 20 | -- other-modules: 21 | other-extensions: TemplateHaskell, DeriveDataTypeable 22 | build-depends: base >=4.7 && <4.8, template-haskell >=2.9 && <2.10 23 | hs-source-dirs: ./ 24 | default-language: Haskell2010 25 | -------------------------------------------------------------------------------- /front_end/overloading/Feldspar/Example.hs: -------------------------------------------------------------------------------- 1 | 2 | module Feldspar.Example 3 | where 4 | 5 | import Feldspar.GADT 6 | 7 | 8 | fib :: Int -> Exp env Int 9 | fib 0 = 0 10 | fib 1 = 1 11 | fib n = 12 | let_ (fib (n-1)) $ 13 | let_ (fib (n-2)) $ 14 | Var Zro + Var (Suc Zro) -- ugh, de Bruijn indices by hand 15 | 16 | 17 | fact :: Int -> Exp env Int 18 | fact 0 = 1 19 | fact n = constant n * fact (n-1) 20 | 21 | 22 | -- a.k.a. binomial coefficients. n >= k > 0 23 | pascal :: Int -> Int -> Exp env Int 24 | pascal _ 0 = 1 25 | pascal n k | k == n = 1 26 | pascal n k = 27 | let_ (pascal (n-1) k) $ 28 | let_ (pascal (n-1) (k-1)) $ 29 | Var Zro + Var (Suc Zro) 30 | 31 | -------------------------------------------------------------------------------- /front_end/overloading/Feldspar/GADT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE RoleAnnotations #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | 7 | -- | Mini feldspar GADT, copied from: 8 | -- https://github.com/shayan-najd/MiniFeldspar/ 9 | 10 | module Feldspar.GADT where 11 | 12 | import Data.Typeable (Typeable) 13 | import Text.PrettyPrint.Leijen 14 | 15 | -- GADT representation. 16 | -- Simply-typed lambda calculus with de Bruijn indices, 17 | -- with integer constants, and addition. 18 | -- Philip Wadler and Shayan Najd, November 2013 19 | 20 | -- Variables 21 | type role Var nominal nominal 22 | data Var e a where 23 | Zro :: Var (e,a) a -- This requires role nominal for the environment param. 24 | Suc :: Var e a -> Var (e,b) a -- So does this 25 | deriving Typeable 26 | 27 | type role Exp nominal nominal 28 | data Exp (e :: *) (a :: *) where 29 | Con :: Int -> Exp e Int 30 | Add :: Exp e Int -> Exp e Int -> Exp e Int 31 | Mul :: Exp e Int -> Exp e Int -> Exp e Int 32 | Var :: Var e a -> Exp e a 33 | Abs :: Typ a -> Exp (e,a) b -> Exp e (a -> b) 34 | App :: Exp e (a -> b) -> Exp e a -> Exp e b 35 | deriving Typeable 36 | 37 | -- Types (Singleton) 38 | data Typ a where 39 | Int :: Typ Int 40 | Arr :: Typ a -> Typ b -> Typ (a -> b) 41 | deriving Typeable 42 | 43 | -- Environment (Singleton) 44 | data Env e where 45 | Emp :: Env () 46 | Ext :: Env e -> Typ a -> Env (e,a) 47 | deriving Typeable 48 | 49 | class Elt a where 50 | eltType :: Typ a 51 | 52 | instance Elt Int where 53 | eltType = Int 54 | 55 | instance (Elt a, Elt b) => Elt (a -> b) where 56 | eltType = Arr eltType eltType 57 | 58 | instance Num (Exp env Int) where 59 | (+) = Add 60 | (*) = Mul 61 | fromInteger n = Con (fromInteger n) 62 | 63 | -- 64 | (-) = error "Exp.(-)" 65 | abs = error "Exp.abs" 66 | signum = error "Exp.signum" 67 | 68 | -- Helpers 69 | -- ------- 70 | 71 | let_ :: Elt a => Exp env a -> Exp (env,a) b -> Exp env b 72 | let_ bnd body = (Abs eltType body) `App` bnd 73 | 74 | constant :: Int -> Exp env Int 75 | constant = Con 76 | 77 | 78 | -- Pretty printer 79 | -- -------------- 80 | 81 | idxToInt :: Var env t -> Int 82 | idxToInt Zro = 0 83 | idxToInt (Suc ix) = idxToInt ix + 1 84 | 85 | prettyOpenExp :: (Doc -> Doc) -> Int -> Exp env a -> Doc 86 | prettyOpenExp wrap lvl = pp 87 | where 88 | ppE :: Exp env a -> Doc 89 | ppE = prettyOpenExp parens lvl 90 | 91 | ppF :: Exp env a -> Doc 92 | ppF fun = 93 | let 94 | (n, body) = count n fun 95 | 96 | count :: Int -> Exp env f -> (Int, Doc) 97 | count l (Abs _ f) = let (i,b) = count l f in (i+1, b) 98 | count l other = (lvl-1, prettyOpenExp id (l+1) other) 99 | in 100 | parens $ sep [ char 'λ' <> hsep [ char 'x' <> int idx | idx <- [lvl .. n] ] <+> char '→' 101 | , hang 2 body ] 102 | 103 | pp :: Exp env a -> Doc 104 | pp (Con i) = int i 105 | pp (Var ix) = char 'x' <> int (lvl - idxToInt ix - 1) 106 | pp (Add x y) = wrap $ ppE x <+> char '+' <+> ppE y 107 | pp (Mul x y) = wrap $ ppE x <+> char '*' <+> ppE y 108 | pp (App f x) = wrap $ sep [ ppE f, hang 2 (ppE x) ] 109 | pp f@Abs{} = ppF f 110 | 111 | 112 | prettyType :: Typ a -> Doc 113 | prettyType Int = text "Int" 114 | prettyType (Arr a b) = parens (prettyType a <+> char '→' <+> prettyType b) 115 | 116 | instance Show (Exp env a) where 117 | show = show . prettyOpenExp id 0 118 | 119 | instance Show (Typ a) where 120 | show = show . prettyType 121 | -------------------------------------------------------------------------------- /front_end/overloading/Feldspar/InterpGADT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE RoleAnnotations #-} 4 | 5 | module Feldspar.InterpGADT where 6 | 7 | import Feldspar.GADT 8 | 9 | -- Extraction of values form environment 10 | get :: Var e a -> e -> a 11 | get Zro (_ ,x) = x 12 | get (Suc n) (xs,_) = get n xs 13 | 14 | -- Extraction of values form environment with singletons 15 | gets :: Var e a -> Env e -> Typ a 16 | gets Zro (Ext _ x) = x 17 | gets (Suc n) (Ext xs _) = gets n xs 18 | gets _ Emp = error "Impossible!" 19 | 20 | -- Evaluation of expressions under specific environment of values 21 | run :: Exp e a -> e -> a 22 | run (Con i) _ = i 23 | run (Var x) r = get x r 24 | run (Abs _ eb) r = \v -> run eb (r,v) 25 | run (App ef ea) r = run ef r $ run ea r 26 | run (Add el er) r = run el r + run er r 27 | run (Mul el er) r = run el r * run er r 28 | 29 | -- Typechecking and returning the type, if successful 30 | chk :: Exp e a -> Env e -> Typ a 31 | chk (Con _) _ = Int 32 | chk (Var x) r = gets x r 33 | chk (Abs ta eb) r = ta `Arr` chk eb (r `Ext` ta) 34 | chk (App ef _ ) r = case chk ef r of 35 | Arr _ tr -> tr 36 | chk (Add _ _ ) _ = Int 37 | chk (Mul _ _ ) _ = Int 38 | 39 | 40 | -- Count the number of terms in an expression 41 | numberOfTerms :: Exp env a -> Int 42 | numberOfTerms = cnt 43 | where 44 | cnt :: Exp env a -> Int 45 | cnt Con{} = 1 46 | cnt (Var ix) = 1 + idxToInt ix + 1 -- indices start from zero 47 | cnt (Abs _ e) = 1 + cnt e -- include terms making up the type? 48 | cnt (App f x) = 1 + cnt f + cnt x 49 | cnt (Add x y) = 1 + cnt x + cnt y 50 | cnt (Mul x y) = 1 + cnt x + cnt y 51 | 52 | 53 | -- Examples 54 | -- -------- 55 | 56 | -- An example expression doubling the input number 57 | dbl :: Exp env (Int -> Int) 58 | dbl = Abs Int (Var Zro `Add` Var Zro) 59 | 60 | -- An example expression composing two types 61 | compose :: (Elt a, Elt b, Elt c) => Exp env ((b -> c) -> (a -> b) -> (a -> c)) 62 | compose 63 | = Abs eltType 64 | $ Abs eltType 65 | $ Abs eltType (Var (Suc (Suc Zro)) `App` (Var (Suc Zro) `App` Var Zro)) 66 | 67 | -- An example expression representing the Integer 4 68 | four :: Exp () Int 69 | four = (compose `App` dbl `App` dbl) `App` Con 1 70 | 71 | -- Two test cases 72 | test :: Bool 73 | test = (case chk four Emp of 74 | Int -> True) 75 | && 76 | (run four () == 4) 77 | 78 | -------------------------------------------------------------------------------- /front_end/overloading/Feldspar/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | 4 | module Feldspar.Test where 5 | 6 | import Feldspar.GADT 7 | import Feldspar.InterpGADT as GADTInterp 8 | 9 | ----------------------------- Tests --------------------------------------- 10 | 11 | test1 :: Exp () (Int -> Int -> Int) 12 | test1 = Abs Int (Abs Int (Var Zro `Add` Var (Suc Zro))) 13 | 14 | test2 :: Exp () Int 15 | test2 = (App (Abs Int (App (Abs Int (Var Zro `Add` Var (Suc Zro))) (Con 1))) (Con 2)) 16 | 17 | result2 :: Int 18 | result2 = GADTInterp.run test2 () 19 | -------------------------------------------------------------------------------- /front_end/overloading/MiniFeldspar.cabal: -------------------------------------------------------------------------------- 1 | name: MiniFeldspar 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | library 7 | default-language: Haskell2010 8 | exposed-modules: Feldspar.GADT 9 | Feldspar.Test 10 | Feldspar.Example 11 | Feldspar.InterpGADT 12 | build-depends: 13 | base >= 4.7 && < 4.10 14 | , wl-pprint >= 1.2 15 | , ghc-prim 16 | , deepseq 17 | 18 | ghc-options: -Wall 19 | -------------------------------------------------------------------------------- /front_end/overloading/OverloadingFeldspar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | 4 | module OverloadingFeldspar where 5 | 6 | import Feldspar.GADT 7 | import Feldspar.InterpGADT 8 | import Prelude (Int,(*),(+),fromInteger, return,(>>)) 9 | import qualified Prelude as P 10 | 11 | x :: Exp () Int 12 | x = 3 + 4 13 | 14 | type EBool e = Exp e (Int -> Int -> Int) 15 | 16 | true :: EBool e 17 | true = Abs Int (Abs Int (Var (Suc Zro))) 18 | 19 | false :: EBool e 20 | false = Abs Int (Abs Int (Var Zro)) 21 | 22 | ifThenElse :: EBool e -> Exp e Int -> Exp e Int -> Exp e Int 23 | ifThenElse b e1 e2 = 24 | App (App b e1) e2 25 | 26 | y :: Exp () Int 27 | y = if true 28 | then x 29 | else 2 * x 30 | 31 | z :: Exp () Int 32 | z = if false 33 | then x 34 | else 2 * x 35 | 36 | main :: P.IO () 37 | main = do P.print (run y ()) 38 | P.print (run z ()) 39 | -------------------------------------------------------------------------------- /install_all.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -xe 4 | 5 | PKGS=" ./front_end/overloading/ \ 6 | ./front_end/directive_driven/ \ 7 | ./middle_end/nanopass/course_example/nanopass-sample.cabal \ 8 | ./middle_end/nanopass/exercise/nanopass-exercise.cabal \ 9 | ./middle_end/syntactic/nanofeldspar.cabal \ 10 | ./middle_end/GADT_transforms/Mini-Accelerate.cabal \ 11 | ./middle_end/multi-level_AST \ 12 | 13 | " 14 | 15 | cabal install -j $PKGS $@ 16 | -------------------------------------------------------------------------------- /lang_features/template_haskell/TemplateHaskell1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | {-| 4 | 5 | See wiki entry here: 6 | 7 | https://wiki.haskell.org/Template_Haskell#What_is_Template_Haskell.3F 8 | 9 | This is a tiny example of how to use template Haskell. Because quotes 10 | and splices must be in different modules, look at both this file and 11 | TemplateHaskell2.hs. 12 | 13 | -} 14 | 15 | module TemplateHaskell1 where 16 | 17 | import Language.Haskell.TH 18 | 19 | -- First, a regular quote. Quotes live in the "Q" monad. 20 | foo :: Q Exp 21 | foo = [| \n -> show n |] 22 | 23 | -- Second, let's see a typed quotation, which guarantees the generated 24 | -- code will typecheck at the specified type, just like MetaML. 25 | baz :: Q (TExp Int) 26 | baz = [|| 3 + 3 ||] 27 | -------------------------------------------------------------------------------- /lang_features/template_haskell/TemplateHaskell2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | {-| 4 | 5 | See wiki entry here: 6 | 7 | https://wiki.haskell.org/Template_Haskell#What_is_Template_Haskell.3F 8 | 9 | This is a tiny example of how to use template Haskell. 10 | 11 | -} 12 | 13 | module Main where 14 | 15 | import Language.Haskell.TH () 16 | import TemplateHaskell1 17 | 18 | -- The simplest thing we can do with something of type `Q Exp` is to 19 | -- splice it in. 20 | bar :: Int -> String 21 | bar = $(foo) 22 | 23 | -- To splice in a typed quotation we use a slightly different syntax: 24 | quux :: Int 25 | quux = $$baz 26 | 27 | main :: IO () 28 | main = print (bar quux) 29 | 30 | -- Now, if we want to inspect those ASTs to programatically transform 31 | -- them, then we need to understand the datatype for ASTs. 32 | 33 | -- The TemplateHaskell representation of Haskell source has 22 cases 34 | -- in `Exp`. This is somewhat less than the (extremely detailed) 35 | -- haskell-src-ext representation of parsed code, which has 52 36 | -- cases. 37 | 38 | -- Still, a TH AST includes do notation, comprehensions, .. sequences, 39 | -- if and multi-if, list literals, infix applications, and record 40 | -- update syntax. 41 | 42 | -- The "th-desugar" package (which "singletons" uses) addresses this. 43 | -- It replaces those fatter sum types with the svelt one below with 44 | -- only nine cases! 45 | {- 46 | data DExp = DVarE Name 47 | | DConE Name 48 | | DLitE Lit 49 | | DAppE DExp DExp 50 | | DLamE [Name] DExp 51 | | DCaseE DExp [DMatch] 52 | | DLetE [DLetDec] DExp 53 | | DSigE DExp DType 54 | | DStaticE DExp 55 | 56 | -} 57 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/Mini-Accelerate.cabal: -------------------------------------------------------------------------------- 1 | name: Mini-Accelerate 2 | version: 0.1.0.0 3 | author: Trevor L. McDonell 4 | maintainer: tmcdonell@cse.unsw.edu.au 5 | build-type: Simple 6 | cabal-version: >=1.10 7 | 8 | library 9 | hs-source-dirs: src 10 | default-language: Haskell2010 11 | exposed-modules: AST Interpreter Pretty Test Type 12 | build-depends: 13 | base >= 4.7 && < 4.9 14 | , wl-pprint >= 1.2 15 | , vector >= 0.10 16 | 17 | -- ghc-options: -Wall -O2 18 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/src/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | -- Language definition 4 | -- 5 | module AST where 6 | 7 | import Array.Sugar 8 | import Type 9 | 10 | -- Environments 11 | -- ------------ 12 | 13 | data Idx env t where 14 | ZeroIdx :: Idx (env, t) t 15 | SuccIdx :: Idx env t -> Idx (env, s) t 16 | 17 | data Env env where 18 | EmptyEnv :: Env () 19 | PushEnv :: Env env -> a -> Env (env, a) 20 | 21 | prjIdx :: Idx env t -> Env env -> t 22 | prjIdx ZeroIdx (PushEnv _ t) = t 23 | prjIdx (SuccIdx ix) (PushEnv env _) = prjIdx ix env 24 | prjIdx _ _ = error "impossible case" 25 | 26 | idxToInt :: Idx env t -> Int 27 | idxToInt ZeroIdx = 0 28 | idxToInt (SuccIdx ix) = 1 + idxToInt ix 29 | 30 | -- Product types 31 | -- ------------- 32 | 33 | data Prod c p where 34 | EmptyProd :: Prod c () 35 | PushProd :: Elt e => Prod c p -> c e -> Prod c (p, e) 36 | 37 | data ProdIdx p e where 38 | ZeroProdIdx :: ProdIdx (p, s) s 39 | SuccProdIdx :: ProdIdx p e -> ProdIdx (p, s) e 40 | 41 | prodIdxToInt :: ProdIdx p e -> Int 42 | prodIdxToInt ZeroProdIdx = 0 43 | prodIdxToInt (SuccProdIdx ix) = 1 + prodIdxToInt ix 44 | 45 | 46 | -- Array computations 47 | -- ------------------ 48 | 49 | type Acc a = OpenAcc () a 50 | 51 | data OpenAcc aenv a where 52 | Alet :: OpenAcc aenv bnd 53 | -> OpenAcc (aenv, bnd) body 54 | -> OpenAcc aenv body 55 | 56 | Avar :: Idx aenv a 57 | -> OpenAcc aenv a 58 | 59 | Use :: (Shape sh, Elt e) 60 | => Array sh e 61 | -> OpenAcc aenv (Array sh e) 62 | 63 | Map :: (Shape sh, Elt a, Elt b) 64 | => Fun aenv (a -> b) 65 | -> OpenAcc aenv (Array sh a) 66 | -> OpenAcc aenv (Array sh b) 67 | 68 | Generate :: (Shape sh, Elt e) 69 | => Exp aenv sh 70 | -> Fun aenv (sh -> e) 71 | -> OpenAcc aenv (Array sh e) 72 | 73 | 74 | -- Scalar functions 75 | -- ---------------- 76 | 77 | type Fun aenv f = OpenFun () aenv f 78 | 79 | data OpenFun env aenv f where 80 | Lam :: Elt a => OpenFun (env,a) aenv b -> OpenFun env aenv (a -> b) 81 | Body :: Elt f => OpenExp env aenv f -> OpenFun env aenv f 82 | 83 | 84 | -- Scalar expressions 85 | -- ------------------ 86 | 87 | type Exp aenv t = OpenExp () aenv t 88 | 89 | data OpenExp env aenv t where 90 | Let :: (Elt bnd, Elt body) 91 | => OpenExp env aenv bnd 92 | -> OpenExp (env, bnd) aenv body 93 | -> OpenExp env aenv body 94 | 95 | Var :: Elt t 96 | => Idx env t 97 | -> OpenExp env aenv t 98 | 99 | Const :: Elt t 100 | => EltRepr t 101 | -> OpenExp env aenv t 102 | 103 | Prod :: (Elt t, IsProduct t) 104 | => Prod (OpenExp env aenv) (ProdRepr t) 105 | -> OpenExp env aenv t 106 | 107 | Prj :: (Elt t, IsProduct t, Elt e) 108 | => ProdIdx (ProdRepr t) e 109 | -> OpenExp env aenv t 110 | -> OpenExp env aenv e 111 | 112 | PrimApp :: (Elt a, Elt r) 113 | => PrimFun (a -> r) 114 | -> OpenExp env aenv a 115 | -> OpenExp env aenv r 116 | 117 | If :: Elt t 118 | => OpenExp env aenv Bool 119 | -> OpenExp env aenv t 120 | -> OpenExp env aenv t 121 | -> OpenExp env aenv t 122 | 123 | Index :: (Shape sh, Elt e) 124 | => Idx aenv (Array sh e) 125 | -> OpenExp env aenv sh 126 | -> OpenExp env aenv e 127 | 128 | 129 | data PrimFun f where 130 | PrimAdd :: NumType a -> PrimFun ((a,a) -> a) 131 | PrimMul :: NumType a -> PrimFun ((a,a) -> a) 132 | PrimToFloat :: PrimFun (Int -> Float) 133 | 134 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/src/Array/Data.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Storage for array data 3 | -- 4 | module Array.Data where 5 | 6 | import Data.Vector.Unboxed as U 7 | 8 | -- Mini-Accelerate Arrays are just unboxed vectors. We only need vectors of 9 | -- primitive types (Int, Float, etc.) and do the unzipping of compound 10 | -- types ourselves. 11 | -- 12 | type ArrayData e = U.Vector e 13 | 14 | class U.Unbox e => ArrayElt e 15 | 16 | instance ArrayElt () 17 | instance ArrayElt Int 18 | instance ArrayElt Float 19 | instance ArrayElt Bool 20 | instance (ArrayElt a, ArrayElt b) => ArrayElt (a, b) 21 | 22 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/src/Fusion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | -- | Fusion transformation 4 | -- 5 | module Fusion where 6 | 7 | import AST 8 | import Substitution 9 | 10 | 11 | -- | Implement operator fusion by rewriting the AST. 12 | -- 13 | fuseAcc :: OpenAcc aenv a -> OpenAcc aenv a 14 | fuseAcc acc = 15 | case acc of 16 | Use xs -> Use xs 17 | Avar ix -> Avar ix 18 | Generate sh f -> Generate sh f 19 | Alet bnd body -> Alet (fuseAcc bnd) (fuseAcc body) 20 | Map f a -> 21 | case fuseAcc a of 22 | Map g b -> Map (f `compose` g) b 23 | Generate sh g -> Generate sh (f `compose` g) 24 | a' -> Map f a' 25 | 26 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/src/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Interpreter where 5 | 6 | import AST 7 | import Type 8 | import Array.Sugar 9 | 10 | run :: Acc a -> a 11 | run = evalOpenAcc EmptyEnv 12 | 13 | 14 | evalOpenAcc :: forall aenv a. Env aenv -> OpenAcc aenv a -> a 15 | evalOpenAcc aenv = go 16 | where 17 | goF :: Fun aenv f -> f 18 | goF = evalOpenFun EmptyEnv aenv 19 | 20 | goE :: Exp aenv e -> e 21 | goE = evalOpenExp EmptyEnv aenv 22 | 23 | go :: OpenAcc aenv s -> s 24 | go (Alet a b) = evalOpenAcc (aenv `PushEnv` go a) b 25 | go (Avar ix) = prjIdx ix aenv 26 | go (Use xs) = xs 27 | go (Map f xs) = mapOp (goF f) (go xs) 28 | go (Generate sh f) = newArray (goE sh) (goF f) 29 | 30 | 31 | mapOp :: (Shape sh, Elt a, Elt b) 32 | => (a -> b) 33 | -> Array sh a 34 | -> Array sh b 35 | mapOp f xs = newArray (shape xs) (\ix -> f (xs ! ix)) 36 | 37 | 38 | evalOpenFun :: Env env -> Env aenv -> OpenFun env aenv f -> f 39 | evalOpenFun env aenv (Body e) = evalOpenExp env aenv e 40 | evalOpenFun env aenv (Lam f) = \x -> evalOpenFun (env `PushEnv` x) aenv f 41 | 42 | 43 | evalOpenExp :: forall env aenv t. Env env -> Env aenv -> OpenExp env aenv t -> t 44 | evalOpenExp env aenv = go 45 | where 46 | go :: OpenExp env aenv s -> s 47 | go (Let a b) = evalOpenExp (env `PushEnv` go a) aenv b 48 | go (Var ix) = prjIdx ix env 49 | go (Const c) = toElt c 50 | go (Prj ix p) = prj ix (fromProd (go p)) 51 | go (Prod p) = toProd (prod p) 52 | go (PrimApp f x) = prim f (go x) 53 | go (Index a ix) = prjIdx a aenv ! go ix 54 | go (If p a b) 55 | | go p = go a 56 | | otherwise = go b 57 | 58 | prj :: ProdIdx p e -> p -> e 59 | prj ZeroProdIdx (_, e) = e 60 | prj (SuccProdIdx ix) (p, _) = prj ix p 61 | 62 | prod :: Prod (OpenExp env aenv) p -> p 63 | prod EmptyProd = () 64 | prod (PushProd p v) = (prod p, go v) 65 | 66 | prim :: PrimFun f -> f 67 | prim (PrimAdd t) = add t 68 | prim (PrimMul t) = mul t 69 | prim PrimToFloat = fromIntegral 70 | 71 | add :: NumType a -> ((a,a) -> a) 72 | add (IntegralNumType t) | IntegralDict <- integralDict t = uncurry (+) 73 | add (FloatingNumType t) | FloatingDict <- floatingDict t = uncurry (+) 74 | 75 | mul :: NumType a -> ((a,a) -> a) 76 | mul (IntegralNumType t) | IntegralDict <- integralDict t = uncurry (*) 77 | mul (FloatingNumType t) | FloatingDict <- floatingDict t = uncurry (*) 78 | 79 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/src/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | -- Pretty printing 7 | -- 8 | module Pretty where 9 | 10 | import AST 11 | import Array.Sugar 12 | import Text.PrettyPrint.Leijen 13 | 14 | prettyAcc 15 | :: forall aenv a. 16 | Int 17 | -> (Doc -> Doc) 18 | -> OpenAcc aenv a 19 | -> Doc 20 | prettyAcc alvl wrap = pp 21 | where 22 | name .$ docs = wrap $ hang 2 (sep (text name : docs)) 23 | 24 | ppE :: OpenExp env aenv t -> Doc 25 | ppE = prettyExp 0 alvl parens 26 | 27 | ppF :: OpenFun env aenv f -> Doc 28 | ppF = parens . prettyFun 0 alvl 29 | 30 | ppA :: OpenAcc aenv arrs -> Doc 31 | ppA = prettyAcc alvl parens 32 | 33 | pp :: OpenAcc aenv arrs -> Doc 34 | pp (Use arr) = wrap (text (show arr)) 35 | pp (Avar ix) = char 'a' <> int (alvl - idxToInt ix - 1) 36 | pp (Alet a b) = 37 | let x = char 'a' <> int alvl 38 | a' = prettyAcc alvl id a 39 | b' = prettyAcc (alvl+1) id b 40 | 41 | isLet Alet{} = True 42 | isLet _ = False 43 | in 44 | if not (isLet a) && isLet b 45 | then wrap $ vcat [ text "let" <+> x <+> equals <+> a' <+> text "in", b' ] 46 | else wrap $ vcat [ text "let" <+> x <+> equals <+> a', text "in" <+> b' ] 47 | 48 | pp (Map f a) = "map" .$ [ ppF f, ppA a ] 49 | pp (Generate sh f) = "generate" .$ [ ppE sh, ppF f ] 50 | 51 | 52 | prettyFun 53 | :: forall env aenv f. 54 | Int 55 | -> Int 56 | -> OpenFun env aenv f 57 | -> Doc 58 | prettyFun lvl alvl fun = 59 | let (n, bodyDoc) = count n fun 60 | in 61 | char '\\' <> hsep [text $ 'x' : show idx | idx <- [lvl..n]] <+> 62 | text "->" <+> bodyDoc 63 | where 64 | count :: Int -> OpenFun env' aenv' fun' -> (Int, Doc) 65 | count l (Body body) = (lvl-1, prettyExp (l + 1) alvl id body) 66 | count l (Lam fun') = let (n, body) = count l fun' in (1 + n, body) 67 | 68 | 69 | prettyExp 70 | :: forall env aenv t. 71 | Int 72 | -> Int 73 | -> (Doc -> Doc) 74 | -> OpenExp env aenv t 75 | -> Doc 76 | prettyExp lvl alvl wrap = pp 77 | where 78 | ppE :: OpenExp env aenv s -> Doc 79 | ppE = prettyExp lvl alvl parens 80 | 81 | ppA :: OpenAcc aenv a -> Doc 82 | ppA = prettyAcc alvl parens 83 | 84 | pp :: OpenExp env aenv t -> Doc 85 | pp (Var ix) = char 'x' <> int (lvl - idxToInt ix - 1) 86 | pp (Const c) = text (show (toElt c :: t)) 87 | pp (Prj ix tup) = wrap (char '#' <> int (prodIdxToInt ix) <+> ppE tup) 88 | 89 | pp (Let a b) = 90 | let x = char 'x' <> int lvl 91 | a' = prettyExp lvl alvl id a 92 | b' = prettyExp (lvl+1) alvl id b 93 | 94 | isLet Let{} = True 95 | isLet _ = False 96 | in 97 | if not (isLet a) && isLet b 98 | then vcat [ text "let" <+> x <+> equals <+> a' <+> text "in", b' ] 99 | else vcat [ text "let" <+> x <+> equals <+> a', text "in" <+> b' ] 100 | 101 | pp (Prod p) = 102 | let collect :: Prod (OpenExp env aenv) p -> [Doc] 103 | collect EmptyProd = [] 104 | collect (PushProd t e) = prettyExp lvl alvl id e : collect t 105 | in 106 | tupled (reverse (collect p)) 107 | 108 | pp (PrimApp f x) = 109 | let ppF :: PrimFun f -> Doc 110 | ppF PrimAdd{} = text "(+)" 111 | ppF PrimMul{} = text "(*)" 112 | ppF PrimToFloat{} = text "toFloat" 113 | in 114 | wrap (ppF f <+> ppE x) 115 | 116 | pp (If p t e) = 117 | hang 3 $ vcat [ text "if" <+> ppE p, text "then" <+> ppE t, text "else" <+> ppE e ] 118 | 119 | pp (Index arr ix) = 120 | wrap $ cat [ ppA (Avar arr), char '!', ppE ix ] 121 | 122 | 123 | instance Show (OpenAcc aenv a) where 124 | show = show . prettyAcc 0 id 125 | 126 | instance Show (OpenFun env aenv f) where 127 | show = show . prettyFun 0 0 128 | 129 | instance Show (OpenExp env aenv t) where 130 | show = show . prettyExp 0 0 id 131 | 132 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/src/Substitution.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- Simultaneous substitution 6 | -- 7 | module Substitution where 8 | 9 | import AST 10 | import Array.Sugar 11 | 12 | 13 | -- | Replace the first variable (ZeroIdx) with the given expression. The 14 | -- environment shrinks. 15 | -- 16 | inline 17 | :: Elt t 18 | => OpenExp (env, s) aenv t 19 | -> OpenExp env aenv s 20 | -> OpenExp env aenv t 21 | inline f g = rebuild (subTop g) f 22 | where 23 | subTop :: Elt t => OpenExp env aenv s -> Idx (env, s) t -> OpenExp env aenv t 24 | subTop s ZeroIdx = s 25 | subTop _ (SuccIdx ix) = Var ix 26 | 27 | 28 | -- | Composition of unary functions. 29 | -- 30 | compose 31 | :: Elt c 32 | => OpenFun env aenv (b -> c) 33 | -> OpenFun env aenv (a -> b) 34 | -> OpenFun env aenv (a -> c) 35 | compose (Lam (Body f)) (Lam (Body g)) = Lam . Body $ rebuild (dot g) f 36 | where 37 | dot :: Elt c => OpenExp (env, a) aenv b -> Idx (env, b) c -> OpenExp (env, a) aenv c 38 | dot s ZeroIdx = s 39 | dot _ (SuccIdx ix) = Var (SuccIdx ix) 40 | 41 | compose _ _ = error "impossible evaluation" 42 | 43 | 44 | -- SEE: [Renaming and Substitution] 45 | -- SEE: [Weakening] 46 | -- 47 | class Syntactic f where 48 | varIn :: Elt t => Idx env t -> f env aenv t 49 | expOut :: Elt t => f env aenv t -> OpenExp env aenv t 50 | weaken :: Elt t => f env aenv t -> f (env, s) aenv t 51 | 52 | 53 | -- Wrapper around indices such that Syntactic elements have the same kind. 54 | -- Here, the second environment 'aenv' is ignored. 55 | -- 56 | newtype Idx' env aenv t = I { unI :: Idx env t } 57 | 58 | instance Syntactic Idx' where 59 | varIn = I 60 | expOut = Var . unI 61 | weaken = I . SuccIdx . unI 62 | 63 | instance Syntactic OpenExp where 64 | varIn = Var 65 | expOut = id 66 | weaken = rebuild (weaken . I) 67 | 68 | 69 | shift :: (Syntactic f, Elt t) 70 | => (forall t'. Elt t' => Idx env t' -> f env' aenv t') 71 | -> Idx' (env, s) aenv t 72 | -> f (env', s) aenv t 73 | shift _ (I ZeroIdx) = varIn ZeroIdx 74 | shift v (I (SuccIdx ix)) = weaken (v ix) 75 | 76 | 77 | rebuild :: forall env env' aenv f t. Syntactic f 78 | => (forall t'. Elt t' => Idx env t' -> f env' aenv t') 79 | -> OpenExp env aenv t 80 | -> OpenExp env' aenv t 81 | rebuild v = go 82 | where 83 | go :: OpenExp env aenv s -> OpenExp env' aenv s 84 | go (Let a b) = Let (go a) (rebuild (shift v . I) b) 85 | go (Var ix) = expOut (v ix) 86 | go (Const c) = Const c 87 | go (PrimApp f x) = PrimApp f (go x) 88 | go (If p t e) = If (go p) (go t) (go e) 89 | go (Prj ix p) = Prj ix (go p) 90 | go (Prod p) = Prod (goP p) 91 | go (Index a ix) = Index a (go ix) 92 | 93 | goP :: Prod (OpenExp env aenv) p -> Prod (OpenExp env' aenv) p 94 | goP EmptyProd = EmptyProd 95 | goP (PushProd p e) = goP p `PushProd` go e 96 | 97 | 98 | -- NOTE: [Renaming and Substitution] 99 | -- 100 | -- To do things like renaming and substitution, we need some operation on 101 | -- variables that we push structurally through terms, applying to each variable. 102 | -- We have a type preserving but environment changing operation: 103 | -- 104 | -- v :: forall t. Idx env t -> f env' aenv t 105 | -- 106 | -- The crafty bit is that 'f' might represent variables (for renaming) or terms 107 | -- (for substitutions). The demonic forall, --- which is to say that the 108 | -- quantifier is in a position which gives us obligation, not opportunity --- 109 | -- forces us to respect type: when pattern matching detects the variable we care 110 | -- about, happily we discover that it has the type we must respect. The demon is 111 | -- not so free to mess with us as one might fear at first. 112 | -- 113 | -- We then lift this to an operation which traverses terms and rebuild them 114 | -- after applying 'v' to the variables: 115 | -- 116 | -- rebuild v :: OpenExp env aenv t -> OpenExp env' aenv t 117 | -- 118 | -- The Syntactic class tells us what we need to know about 'f' if we want to be 119 | -- able to rebuild terms. In essence, the crucial functionality is to propagate 120 | -- a class of operations on variables that is closed under shifting. 121 | -- 122 | 123 | -- NOTE: [Weakening] 124 | -- 125 | -- Weakening is something we usually take for granted: every time you learn a 126 | -- new word, old sentences still make sense. If a conclusion is justified by a 127 | -- hypothesis, it is still justified if you add more hypotheses. Similarly, a 128 | -- term remains in scope if you bind more (fresh) variables. Weakening is the 129 | -- operation of shifting things from one scope to a larger scope in which new 130 | -- things have become meaningful, but no old things have vanished. 131 | -- 132 | -- When we use a named representation (or HOAS) we get weakening for free. But 133 | -- in the de Bruijn representation weakening takes work: you have to shift all 134 | -- variables references to make room for the new bindings. 135 | -- 136 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/src/Test.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | 3 | module Test where 4 | 5 | import AST 6 | import Type 7 | import Pretty () 8 | import Array.Sugar 9 | import Substitution 10 | import Interpreter 11 | import Fusion 12 | 13 | 14 | -- EXERCISES 15 | -- ========= 16 | -- 17 | -- Try to get the following expressions to fuse! You will need to 18 | -- complete the definitions in Substitution.hs and Fusion.hs. 19 | -- 20 | -- You can evaluate the expressions with 'run'. 21 | -- 22 | 23 | -- function composition 24 | -- 25 | ex01 :: Fun () (Int -> Float) 26 | ex01 = f2 `compose` f1 27 | 28 | 29 | -- map/map fusion 30 | -- 31 | ex02 :: Acc (Vector Float) 32 | ex02 33 | = fuseAcc 34 | $ Map f2 (Map f1 a3) 35 | 36 | 37 | -- map/generate fusion 38 | -- 39 | ex03 :: Acc (Array DIM2 Float) 40 | ex03 41 | = fuseAcc 42 | $ Map f2 (Map f1 (Generate (constant (Z:.2:.2)) f5)) 43 | 44 | 45 | -- removing obstacles to fusion 46 | -- 47 | ex04 :: Acc (Array DIM1 Float) 48 | ex04 49 | = fuseAcc 50 | $ Map f2 (Alet a3 (Map f1 (Avar ZeroIdx))) 51 | 52 | 53 | -- Example program fragments: construct your own tests! 54 | -- ==================================================== 55 | 56 | -- Array computations 57 | 58 | a0 :: Vector Int 59 | a0 = fromList (Z :. 10) [1 .. 10] 60 | 61 | a1 :: Array DIM2 Float 62 | a1 = fromList (Z :. 5 :. 2) [1 .. 10] 63 | 64 | a2 :: Array DIM1 (Int,Bool) 65 | a2 = fromList (Z :. 10) [ (x, x `mod` 5 == 0) | x <- [1,3 .. 20] ] 66 | 67 | a3 :: Acc (Vector Int) 68 | a3 = Use a0 69 | 70 | a4 :: Acc (Array DIM2 Float) 71 | a4 = Use a1 72 | 73 | a5 :: Acc (Vector (Int,Bool)) 74 | a5 = Use a2 75 | 76 | a6 :: Acc (Vector Int) 77 | a6 = Map f1 a3 78 | 79 | a7 :: Acc (Vector Float) 80 | a7 = Map f2 a6 81 | 82 | -- TODO: map/map fusion 83 | a8 :: Acc (Vector Float) 84 | a8 = Map f2 85 | $ Map f1 a3 86 | 87 | a9 :: Acc (Array DIM2 Int) 88 | a9 = Generate (constant (Z:.2:.2)) f5 89 | 90 | -- TODO: map/generate fusion 91 | a10 :: Acc (Array DIM2 Float) 92 | a10 = Map f2 93 | $ Map f1 94 | $ a9 95 | 96 | a11 :: Acc (Array DIM2 Float) 97 | a11 = Alet a10 98 | $ Generate (constant (Z:.2:.2)) f4 99 | 100 | 101 | -- Scalar functions 102 | 103 | f1 :: OpenFun env aenv (Int -> Int) 104 | f1 = Lam $ Body $ PrimApp (PrimAdd (IntegralNumType (TypeInt IntegralDict))) 105 | (Prod $ EmptyProd `PushProd` Var ZeroIdx 106 | `PushProd` Const 1) 107 | 108 | f2 :: OpenFun env aenv (Int -> Float) 109 | f2 = Lam $ Body $ PrimApp PrimToFloat (Var ZeroIdx) 110 | 111 | f3 :: OpenFun env aenv (Int -> Float) 112 | f3 = f2 `compose` f1 113 | 114 | f4 :: Elt e => OpenFun env (aenv, Array DIM2 e) (DIM2 -> e) 115 | f4 = Lam $ Body $ Index ZeroIdx (Var ZeroIdx) 116 | 117 | f5 :: Shape sh => OpenFun env aenv (sh -> Int) 118 | f5 = Lam $ Body $ constant 0 119 | 120 | 121 | -- Scalar expressions 122 | 123 | constant :: Elt t => t -> OpenExp env aenv t 124 | constant = Const . fromElt 125 | 126 | e0 :: OpenExp env aenv Int 127 | e0 = If (constant True) (constant 3) (constant 4) 128 | 129 | e1 :: OpenExp env aenv Int 130 | e1 = Let (constant 5) (Var ZeroIdx) 131 | 132 | e2 :: OpenExp env aenv Int 133 | e2 = If (constant True) (constant 11) e1 134 | 135 | e3 :: OpenExp env aenv Int 136 | e3 = Let (constant 5) (If (constant True) (Var ZeroIdx) (constant 4)) 137 | 138 | e4 :: OpenExp env aenv Int 139 | e4 = Let (constant 4) 140 | $ Let (constant 5) 141 | $ PrimApp (PrimAdd (IntegralNumType (TypeInt IntegralDict))) 142 | (Prod $ EmptyProd `PushProd` Var ZeroIdx 143 | `PushProd` Var (SuccIdx ZeroIdx)) 144 | 145 | e5 :: OpenExp env aenv Bool 146 | e5 = constant True 147 | 148 | e6 :: OpenExp env aenv Bool 149 | e6 = Let e5 150 | $ If (Var ZeroIdx) (constant False) 151 | (Var ZeroIdx) 152 | 153 | e7 :: OpenExp env aenv (Int,Float) 154 | e7 = constant (1,pi) 155 | 156 | e8 :: OpenExp env aenv Float 157 | e8 = Let e7 158 | $ Prj ZeroProdIdx (Var ZeroIdx) 159 | 160 | e9 :: OpenExp env aenv Float 161 | e9 = Let (constant (pi, 8, 4.86)) 162 | $ Let (PrimApp (PrimMul (FloatingNumType (TypeFloat FloatingDict))) 163 | (Prod (EmptyProd `PushProd` Prj ZeroProdIdx (Var ZeroIdx) 164 | `PushProd` PrimApp PrimToFloat (Prj (SuccProdIdx ZeroProdIdx) (Var ZeroIdx))))) 165 | (PrimApp (PrimAdd (FloatingNumType (TypeFloat FloatingDict))) 166 | (Prod (EmptyProd `PushProd` Var ZeroIdx 167 | `PushProd` Prj (SuccProdIdx (SuccProdIdx ZeroProdIdx)) (Var (SuccIdx ZeroIdx))))) 168 | 169 | e10 :: OpenExp env aenv (Int, (Float, Int), Bool) 170 | e10 = constant (1, (4,2), True) 171 | 172 | e11 :: OpenExp env aenv (Float,Int) 173 | e11 = Let e10 174 | $ Prj (SuccProdIdx ZeroProdIdx) (Var ZeroIdx) 175 | 176 | e12 :: OpenExp env aenv DIM1 177 | e12 = constant (Z :. 10) 178 | 179 | e13 :: OpenExp env aenv (Any DIM2) 180 | e13 = constant Any 181 | 182 | e14 :: OpenExp env aenv ((Bool,Int), Float) 183 | e14 = constant ((True,42), pi) 184 | 185 | e15 :: OpenExp env aenv (Bool,Int,Float) 186 | e15 = constant (True,1,2) 187 | 188 | e16 :: OpenExp env aenv (Bool, (Int,Float)) 189 | e16 = constant (False, (12,42)) 190 | 191 | e17 :: OpenExp env aenv Float 192 | e17 = Let e3 193 | $ PrimApp PrimToFloat (Var ZeroIdx) 194 | 195 | e18 :: OpenExp env aenv DIM1 196 | e18 = Let (constant (4 :: Int, Z:.10 :: DIM1)) 197 | $ Prj ZeroProdIdx (Var ZeroIdx) 198 | 199 | -------------------------------------------------------------------------------- /middle_end/GADT_transforms/src/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | -- | Type hierarchy 4 | -- 5 | module Type where 6 | 7 | import Text.PrettyPrint.Leijen 8 | 9 | 10 | integralDict :: IntegralType a -> IntegralDict a 11 | integralDict (TypeInt d) = d 12 | 13 | floatingDict :: FloatingType a -> FloatingDict a 14 | floatingDict (TypeFloat d) = d 15 | 16 | data IntegralDict a where 17 | IntegralDict :: (Integral a, Num a, Show a, Eq a) => IntegralDict a 18 | 19 | data FloatingDict a where 20 | FloatingDict :: (Floating a, Fractional a, Num a, Show a, Eq a) => FloatingDict a 21 | 22 | data NonNumDict a where 23 | NonNumDict :: (Show a, Eq a) => NonNumDict a 24 | 25 | data ScalarType a where 26 | NumScalarType :: NumType a -> ScalarType a 27 | NonNumScalarType :: NonNumType a -> ScalarType a 28 | 29 | data NumType a where 30 | IntegralNumType :: IntegralType a -> NumType a 31 | FloatingNumType :: FloatingType a -> NumType a 32 | 33 | data IntegralType a where 34 | TypeInt :: IntegralDict Int -> IntegralType Int 35 | 36 | data FloatingType a where 37 | TypeFloat :: FloatingDict Float -> FloatingType Float 38 | 39 | data NonNumType a where 40 | TypeUnit :: NonNumType () 41 | TypeBool :: NonNumDict Bool -> NonNumType Bool 42 | 43 | instance Show (ScalarType t) where 44 | show (NumScalarType t) = show t 45 | show (NonNumScalarType t) = show t 46 | 47 | instance Show (NumType a) where 48 | show (IntegralNumType t) = show t 49 | show (FloatingNumType t) = show t 50 | 51 | instance Show (IntegralType a) where 52 | show TypeInt{} = "Int" 53 | 54 | instance Show (FloatingType a) where 55 | show TypeFloat{} = "Float" 56 | 57 | instance Show (NonNumType a) where 58 | show TypeUnit = "()" 59 | show TypeBool{} = "Bool" 60 | 61 | 62 | -- Type refication 63 | -- --------------- 64 | 65 | data TypeR a where 66 | TypeRzero :: TypeR () 67 | TypeRscalar :: ScalarType a -> TypeR a 68 | TypeRsnoc :: TypeR a -> TypeR b -> TypeR (a, b) 69 | 70 | instance Show (TypeR a) where 71 | show = show . ppTypeR 72 | 73 | ppTypeR :: TypeR a -> Doc 74 | ppTypeR = tupled . go 75 | where 76 | tup [] = empty 77 | tup [x] = x 78 | tup xs = tupled xs 79 | 80 | go :: TypeR a -> [Doc] 81 | go TypeRzero = [] 82 | go (TypeRscalar t) = [ text (show t) ] 83 | go (TypeRsnoc TypeRzero b@TypeRsnoc{}) = [ tup (go b) ] -- 'b' is terminated at this point 84 | go (TypeRsnoc a@TypeRsnoc{} b@TypeRsnoc{}) = [ tup (go a), tup (go b) ] -- meet point of a pair of tuples 85 | go (TypeRsnoc a b) = go a ++ go b 86 | -------------------------------------------------------------------------------- /middle_end/multi-level_AST/Feldspar/InterpADT.hs: -------------------------------------------------------------------------------- 1 | module Feldspar.InterpADT where 2 | 3 | import Feldspar.ManualADT 4 | import Control.Applicative 5 | 6 | -- Values 7 | data Val = 8 | Num Int 9 | | Fun (Val -> Val) 10 | 11 | instance Show Val where 12 | show (Num i) = "(Num " ++ show i ++ ")" 13 | show (Fun _) = "Function" 14 | 15 | natToInt :: Var -> Int 16 | natToInt Zro = 0 17 | natToInt (Suc n) = (natToInt n) + 1 18 | 19 | -- Equality between types 20 | (===) :: Monad m => Typ -> Typ -> m () 21 | Int === Int = return () 22 | (Arr t1 t2) === (Arr t1' t2') = do t1 === t1' 23 | t2 === t2' 24 | _ === _ = fail "Type Error!" 25 | 26 | -- Extraction of values form environment 27 | get :: Monad m => Var -> [a] -> m a 28 | get Zro (x:_) = return x 29 | get (Suc n) (_:xs) = get n xs 30 | get _ [] = fail "Scope Error!" 31 | 32 | -- Application of two values 33 | app :: Monad m => Val -> Val -> m Val 34 | app (Fun f) v = return (f v) 35 | app _ _ = fail "Type Error!" 36 | 37 | -- Addition of two values 38 | add :: Monad m => Val -> Val -> m Val 39 | add (Num i) (Num j) = return (Num (i + j)) 40 | add _ (_ ) = fail "Type Error!" 41 | 42 | -- Evaluation of expressions under specific environment of values 43 | run :: Exp -> [Val] -> ErrM Val 44 | run (Con i) _ = return (Num i) 45 | run (Var x) r = get x r 46 | run (Abs _ eb) r = return (Fun (\ v -> case run eb (v : r) of 47 | Rgt vr -> vr 48 | Lft s -> error s)) 49 | run (App ef ea) r = do vf <- run ef r 50 | va <- run ea r 51 | vf `app` va 52 | run (Add el er) r = do vl <- run el r 53 | vr <- run er r 54 | vl `add` vr 55 | 56 | -- Typechecking and returning the type, if successful 57 | chk :: Monad m => Exp -> [Typ] -> m Typ 58 | chk (Con _) _ = return Int 59 | chk (Var x) r = get x r 60 | chk (Abs ta eb) r = do tr <- chk eb (ta : r) 61 | return (ta `Arr` tr) 62 | chk (App ef ea) r = do ta `Arr` tr <- chk ef r 63 | ta' <- chk ea r 64 | ta === ta' 65 | return tr 66 | chk (Add el er) r = do tl <- chk el r 67 | tr <- chk er r 68 | tl === Int 69 | tr === Int 70 | return Int 71 | 72 | -- An example expression doubling the input number 73 | dbl :: Exp 74 | dbl = Abs Int (Var Zro `Add` Var Zro) 75 | 76 | -- An example expression composing two types 77 | compose :: Typ -> Typ -> Typ -> Exp 78 | compose s t u = Abs (Arr t u) 79 | (Abs (Arr s t) 80 | (Abs s 81 | (Var (Suc (Suc Zro)) `App` (Var (Suc Zro) `App` Var Zro)))) 82 | 83 | -- An example expression representing the Integer 4 84 | four :: Exp 85 | four = (compose Int Int Int `App` dbl `App` dbl) `App` (Con 1) 86 | 87 | -- Two test cases 88 | test :: Bool 89 | test = (chk four [] == Just Int) 90 | && 91 | (case run four [] of 92 | Rgt (Num 4) -> True 93 | _ -> False) 94 | 95 | -------------------------------------------------------------------------------- 96 | -- From ErrorMonad.hs: 97 | 98 | data ErrM t = Rgt t 99 | | Lft String 100 | deriving (Eq , Show) 101 | 102 | instance Functor ErrM where 103 | fmap f (Rgt x) = Rgt (f x) 104 | fmap _ (Lft x) = Lft x 105 | 106 | instance Applicative ErrM where 107 | pure = return 108 | e1 <*> e2 = do v1 <- e1 109 | v2 <- e2 110 | return (v1 v2) 111 | 112 | instance Monad ErrM where 113 | return = Rgt 114 | Lft l >>= _ = Lft l 115 | Rgt r >>= k = k r 116 | fail x = Lft x 117 | -------------------------------------------------------------------------------- /middle_end/multi-level_AST/Feldspar/Test2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | 4 | module Feldspar.Test2 where 5 | 6 | import Data.Typeable 7 | import Text.Printf 8 | import qualified Feldspar.GADT as GADT 9 | import qualified Feldspar.ManualADT as ADT 10 | import qualified Feldspar.InterpADT as ADTInterp 11 | import qualified Feldspar.InterpGADT as GADTInterp 12 | 13 | ----------------------------- Tests --------------------------------------- 14 | 15 | test1 :: GADT.Exp () (Int -> Int -> Int) 16 | test1 = GADT.Abs GADT.Int (GADT.Abs GADT.Int (GADT.Var GADT.Zro `GADT.Add` GADT.Var (GADT.Suc GADT.Zro))) 17 | 18 | test2 :: GADT.Exp () Int 19 | test2 = (GADT.App (GADT.Abs GADT.Int (GADT.App (GADT.Abs GADT.Int (GADT.Var GADT.Zro `GADT.Add` GADT.Var (GADT.Suc GADT.Zro))) (GADT.Con 1))) (GADT.Con 2)) 20 | 21 | testADT :: ADT.Exp -> Int 22 | testADT adt = 23 | case ADT.upExp adt of 24 | Right (ADT.SealedExp e) 25 | | Just gadt <- gcast e -> GADTInterp.run gadt () 26 | _ -> error "up conversion failed" 27 | 28 | -- TODO: We have problems unpacking from a SealedExp since we don't have 29 | -- enough inherent constraints to make Haskell happy unifing the various 30 | -- types that it needs to. We need to probably do the same business here 31 | -- that we did elsewhere in order to give Haskell enough info to allow it 32 | -- to unify them for us. 33 | roundtrip :: forall e a. (Typeable e) => String -> GADT.Exp e a -> IO () 34 | roundtrip name gadt = do 35 | let adt = ADT.downExp gadt 36 | printf "Test %s:\n" name 37 | printf " Evaled: %s\n" (show (testADT adt)) 38 | printf " DownCvt: %s\n" (show adt) 39 | case (ADTInterp.run adt []) of 40 | ADTInterp.Rgt a -> printf " Evaled: %s\n" (show a) 41 | _ -> printf " Failed to evaluate Expression: %s\n" (show adt) 42 | 43 | -- foo :: IO () 44 | -- foo = roundtrip "foo" test1 45 | 46 | runTest :: IO () 47 | runTest = roundtrip "bar" test2 48 | -------------------------------------------------------------------------------- /middle_end/multi-level_AST/Feldspar/TypeCase.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators, Rank2Types, MagicHash #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | 4 | -- | Exposes an interface for deconstructing typeable *instances*. 5 | -- This module only performs this trick for arrows and 2-tuples. 6 | 7 | module Feldspar.TypeCase 8 | ( typeCaseArrow 9 | , TypeCaseArrow(..) 10 | , typeCaseTuple 11 | , TypeCaseTuple(..) 12 | , typeCaseTimes 13 | , TypeCaseTimes(..) 14 | , typeCaseTimess 15 | , TypeCaseTimess(..) 16 | ) where 17 | 18 | import Data.Typeable 19 | import Feldspar.TypeableMagic 20 | 21 | _main :: IO () 22 | _main = do 23 | print (example1 (length :: String -> Int) "abc") -- Just 3 24 | print (example1 (length :: [Int] -> Int) "abc") -- Nothing 25 | 26 | example1 :: forall arr a. (Typeable arr, Typeable a) => arr -> a -> Maybe Int 27 | example1 arr a = do 28 | -- Check that "arr" is a function from the type of "a" to Int 29 | TypeCaseArrow (Refl :: arr :~: (b -> c)) <- typeCaseArrow 30 | Refl :: b :~: a <- gcast Refl 31 | Refl :: c :~: Int <- gcast Refl 32 | return (arr a) 33 | 34 | -- | Witness the arrow-ness of a type. 35 | data TypeCaseArrow a where 36 | TypeCaseArrow :: (Typeable b, Typeable c) => 37 | (a :~: (b -> c)) -> TypeCaseArrow a 38 | 39 | -- | Witness the tuple-ness of a type. 40 | data TypeCaseTuple a where 41 | TypeCaseTuple :: (Typeable b, Typeable c) => 42 | (a :~: (b,c)) -> TypeCaseTuple a 43 | 44 | -- | Test a Typeable type to see if it is an arrow. If so, return a 45 | -- data structure capable of witnessing that fact for the GHC type checker. 46 | typeCaseArrow :: forall arr. (Typeable arr) => Maybe (TypeCaseArrow arr) 47 | typeCaseArrow = case splitTyConApp (typeRep (Proxy :: Proxy arr)) of 48 | (op, [b,c]) | op == typeRepTyCon (typeRep (Proxy :: Proxy (->))) 49 | -> recoverTypeable b (\(_ :: Proxy b) -> 50 | recoverTypeable c (\(_ :: Proxy c) -> 51 | fmap TypeCaseArrow (gcast Refl :: Maybe (arr :~: (b -> c))))) 52 | _ -> Nothing 53 | -- | Ditto for tuples. 54 | typeCaseTuple :: forall arr. (Typeable arr) => Maybe (TypeCaseTuple arr) 55 | typeCaseTuple = case splitTyConApp (typeRep (Proxy :: Proxy arr)) of 56 | (op, [b,c]) | op == typeRepTyCon (typeRep (Proxy :: Proxy (,))) 57 | -> recoverTypeable b (\(_ :: Proxy b) -> 58 | recoverTypeable c (\(_ :: Proxy c) -> 59 | fmap TypeCaseTuple (gcast Refl :: Maybe (arr :~: (b,c))))) 60 | _ -> Nothing 61 | 62 | ---------------------------- Typecase on user defined data type ----------- 63 | 64 | data Times t1 t2 = Times t1 t2 deriving (Typeable) 65 | 66 | data TypeCaseTimes a where 67 | TypeCaseTimes :: (Typeable b, Typeable c) => 68 | (a :~: (Times b c)) -> TypeCaseTimes a 69 | 70 | typeCaseTimes :: forall arr. (Typeable arr) => Maybe (TypeCaseTimes arr) 71 | typeCaseTimes = case splitTyConApp (typeRep (Proxy :: Proxy arr)) of 72 | (op, [b,c]) | op == typeRepTyCon (typeRep (Proxy :: Proxy (Times))) 73 | -> recoverTypeable b (\(_ :: Proxy b) -> 74 | recoverTypeable c (\(_ :: Proxy c) -> 75 | fmap TypeCaseTimes (gcast Refl :: Maybe (arr :~: (Times b c))))) 76 | _ -> Nothing 77 | 78 | --------------------------- Typecase on user defined GADT ----------------- 79 | 80 | data Timess t1 t2 where 81 | Timess :: t1 -> t2 -> Int -> Timess t1 t2 82 | deriving (Typeable) 83 | 84 | data TypeCaseTimess a where 85 | TypeCaseTimess :: (Typeable b, Typeable c) => 86 | (a :~: (Timess b c)) -> TypeCaseTimess a 87 | 88 | typeCaseTimess :: forall arr. (Typeable arr) => Maybe (TypeCaseTimess arr) 89 | typeCaseTimess = case splitTyConApp (typeRep (Proxy :: Proxy arr)) of 90 | (op, [b,c]) | op == typeRepTyCon (typeRep (Proxy :: Proxy (Timess))) 91 | -> recoverTypeable b (\(_ :: Proxy b) -> 92 | recoverTypeable c (\(_ :: Proxy c) -> 93 | fmap TypeCaseTimess (gcast Refl :: Maybe (arr :~: (Timess b c))))) 94 | _ -> Nothing 95 | -------------------------------------------------------------------------------- /middle_end/multi-level_AST/Feldspar/TypeableMagic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators, Rank2Types, MagicHash #-} 2 | -- | This is a *trusted* module which implements a mechanism for 3 | -- Typeable dictionary recovery. 4 | 5 | module Feldspar.TypeableMagic (recoverTypeable) where 6 | 7 | import Data.Typeable 8 | import Unsafe.Coerce (unsafeCoerce) 9 | -- import Debug.Trace 10 | import GHC.Prim (Proxy#) 11 | 12 | newtype Magic ans = Magic (forall a. (Typeable a) => Proxy a -> ans) 13 | newtype Voodoo = Voodoo (forall a. Proxy# a -> TypeRep) 14 | 15 | -- | For a given TypeRep, there must have been a Typeable dictionary. 16 | -- This allows you to recover it. 17 | recoverTypeable :: TypeRep -> (forall a. (Typeable a) => Proxy a -> ans) -> ans 18 | recoverTypeable rep f = unsafeCoerce (Magic f) (Voodoo (\_ -> rep)) Proxy 19 | -------------------------------------------------------------------------------- /middle_end/multi-level_AST/MiniFeldspar2.cabal: -------------------------------------------------------------------------------- 1 | name: MiniFeldspar2 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | library 7 | default-language: Haskell2010 8 | exposed-modules: 9 | Feldspar.GeneratedADT 10 | Feldspar.InterpADT 11 | Feldspar.ManualADT 12 | Feldspar.Test2 13 | Feldspar.TypeCase 14 | Feldspar.TypeableMagic 15 | other-modules: Feldspar.GADT 16 | Feldspar.Test 17 | Feldspar.Example 18 | Feldspar.InterpGADT 19 | hs-source-dirs: ./ ../../front_end/overloading/ 20 | build-depends: 21 | base >= 4.7 && < 4.10 22 | , wl-pprint >= 1.2 23 | , ghc-prim 24 | , deepseq 25 | 26 | ghc-options: -Wall 27 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L00VerifyScheme.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L00VerifyScheme where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = ExprP Expr 14 | data Expr 15 | = Immediate Immediate 16 | | Quote Datum 17 | | Let [(UVar,Expr)] [Body] 18 | | Letrec [(UVar,Expr)] [Body] 19 | | Lambda [UVar] [Body] 20 | | And [Expr] 21 | | Or [Expr] 22 | | Not Expr 23 | | If1 Expr Expr 24 | | If2 Expr Expr Expr 25 | | Begin [Expr] Expr 26 | | Set UVar Expr 27 | | App1 ValPrim [Expr] 28 | | App2 EffectPrim [Expr] 29 | | App3 PredPrim [Expr] 30 | | App4 Expr [Expr] 31 | | UVar UVar 32 | data Body 33 | = ExprB Expr 34 | 35 | instance PP Prog where 36 | pp (ExprP e) = (pp e) 37 | ppp (ExprP e) = (ppp e) 38 | instance PP Expr where 39 | pp (Immediate i) = (pp i) 40 | pp (Quote d) = (ppSexp [fromByteString "quote",(pp d)]) 41 | pp (Let l l2) = (ppSexp (fromByteString "let" : ((ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)) : (map pp l2)))) 42 | pp (Letrec l l2) = (ppSexp (fromByteString "letrec" : ((ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)) : (map pp l2)))) 43 | pp (Lambda l l2) = (ppSexp (fromByteString "lambda" : ((ppSexp (map pp l)) : (map pp l2)))) 44 | pp (And l) = (ppSexp (fromByteString "and" : (map pp l))) 45 | pp (Or l) = (ppSexp (fromByteString "or" : (map pp l))) 46 | pp (Not e) = (ppSexp [fromByteString "not",(pp e)]) 47 | pp (If1 e e2) = (ppSexp [fromByteString "if",(pp e),(pp e2)]) 48 | pp (If2 e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 49 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 50 | pp (Set u e) = (ppSexp [fromByteString "set!",(pp u),(pp e)]) 51 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 52 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 53 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 54 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 55 | pp (UVar u) = (pp u) 56 | ppp (Immediate i) = (ppp i) 57 | ppp (Quote d) = (pppSexp [text "quote",(ppp d)]) 58 | ppp (Let l l2) = (pppSexp (text "let" : ((pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)) : (map ppp l2)))) 59 | ppp (Letrec l l2) = (pppSexp (text "letrec" : ((pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)) : (map ppp l2)))) 60 | ppp (Lambda l l2) = (pppSexp (text "lambda" : ((pppSexp (map ppp l)) : (map ppp l2)))) 61 | ppp (And l) = (pppSexp (text "and" : (map ppp l))) 62 | ppp (Or l) = (pppSexp (text "or" : (map ppp l))) 63 | ppp (Not e) = (pppSexp [text "not",(ppp e)]) 64 | ppp (If1 e e2) = (pppSexp [text "if",(ppp e),(ppp e2)]) 65 | ppp (If2 e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 66 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 67 | ppp (Set u e) = (pppSexp [text "set!",(ppp u),(ppp e)]) 68 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 69 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 70 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 71 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 72 | ppp (UVar u) = (ppp u) 73 | instance PP Body where 74 | pp (ExprB e) = (pp e) 75 | ppp (ExprB e) = (ppp e) 76 | 77 | deriving instance Eq Prog 78 | deriving instance Read Prog 79 | deriving instance Show Prog 80 | deriving instance Ord Prog 81 | deriving instance Eq Expr 82 | deriving instance Read Expr 83 | deriving instance Show Expr 84 | deriving instance Ord Expr 85 | deriving instance Eq Body 86 | deriving instance Read Body 87 | deriving instance Show Body 88 | deriving instance Ord Body 89 | 90 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L01ParseScheme.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L01ParseScheme where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = ExprP Expr 14 | data Body 15 | = ExprB Expr 16 | data Expr 17 | = Quote Datum 18 | | Let [(UVar,Expr)] Body 19 | | Letrec [(UVar,Expr)] Body 20 | | Lambda [UVar] Body 21 | | If Expr Expr Expr 22 | | Begin [Expr] Expr 23 | | Set UVar Expr 24 | | App1 ValPrim [Expr] 25 | | App2 EffectPrim [Expr] 26 | | App3 PredPrim [Expr] 27 | | App4 Expr [Expr] 28 | | UVar UVar 29 | 30 | instance PP Prog where 31 | pp (ExprP e) = (pp e) 32 | ppp (ExprP e) = (ppp e) 33 | instance PP Body where 34 | pp (ExprB e) = (pp e) 35 | ppp (ExprB e) = (ppp e) 36 | instance PP Expr where 37 | pp (Quote d) = (ppSexp [fromByteString "quote",(pp d)]) 38 | pp (Let l b) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp b)]) 39 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp b)]) 40 | pp (Lambda l b) = (ppSexp [fromByteString "lambda",(ppSexp (map pp l)),(pp b)]) 41 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 42 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 43 | pp (Set u e) = (ppSexp [fromByteString "set!",(pp u),(pp e)]) 44 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 45 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 46 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 47 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 48 | pp (UVar u) = (pp u) 49 | ppp (Quote d) = (pppSexp [text "quote",(ppp d)]) 50 | ppp (Let l b) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp b)]) 51 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp b)]) 52 | ppp (Lambda l b) = (pppSexp [text "lambda",(pppSexp (map ppp l)),(ppp b)]) 53 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 54 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 55 | ppp (Set u e) = (pppSexp [text "set!",(ppp u),(ppp e)]) 56 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 57 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 58 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 59 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 60 | ppp (UVar u) = (ppp u) 61 | 62 | deriving instance Eq Prog 63 | deriving instance Read Prog 64 | deriving instance Show Prog 65 | deriving instance Ord Prog 66 | deriving instance Eq Body 67 | deriving instance Read Body 68 | deriving instance Show Body 69 | deriving instance Ord Body 70 | deriving instance Eq Expr 71 | deriving instance Read Expr 72 | deriving instance Show Expr 73 | deriving instance Ord Expr 74 | 75 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L02ConvertComplexDatum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L02ConvertComplexDatum where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = ExprP Expr 14 | data Body 15 | = ExprB Expr 16 | data Expr 17 | = Let [(UVar,Expr)] Body 18 | | Letrec [(UVar,Expr)] Body 19 | | Lambda [UVar] Body 20 | | If Expr Expr Expr 21 | | Begin [Expr] Expr 22 | | Set UVar Expr 23 | | App1 ValPrim [Expr] 24 | | App2 EffectPrim [Expr] 25 | | App3 PredPrim [Expr] 26 | | App4 Expr [Expr] 27 | | UVar UVar 28 | | Quote Immediate 29 | 30 | instance PP Prog where 31 | pp (ExprP e) = (pp e) 32 | ppp (ExprP e) = (ppp e) 33 | instance PP Body where 34 | pp (ExprB e) = (pp e) 35 | ppp (ExprB e) = (ppp e) 36 | instance PP Expr where 37 | pp (Let l b) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp b)]) 38 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp b)]) 39 | pp (Lambda l b) = (ppSexp [fromByteString "lambda",(ppSexp (map pp l)),(pp b)]) 40 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 41 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 42 | pp (Set u e) = (ppSexp [fromByteString "set!",(pp u),(pp e)]) 43 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 44 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 45 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 46 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 47 | pp (UVar u) = (pp u) 48 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 49 | ppp (Let l b) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp b)]) 50 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp b)]) 51 | ppp (Lambda l b) = (pppSexp [text "lambda",(pppSexp (map ppp l)),(ppp b)]) 52 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 53 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 54 | ppp (Set u e) = (pppSexp [text "set!",(ppp u),(ppp e)]) 55 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 56 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 57 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 58 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 59 | ppp (UVar u) = (ppp u) 60 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 61 | 62 | deriving instance Eq Prog 63 | deriving instance Read Prog 64 | deriving instance Show Prog 65 | deriving instance Ord Prog 66 | deriving instance Eq Body 67 | deriving instance Read Body 68 | deriving instance Show Body 69 | deriving instance Ord Body 70 | deriving instance Eq Expr 71 | deriving instance Read Expr 72 | deriving instance Show Expr 73 | deriving instance Ord Expr 74 | 75 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L03UncoverAssigned.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L03UncoverAssigned where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Expr Expr 14 | data Expr 15 | = Let [(UVar,Expr)] Body 16 | | Letrec [(UVar,Expr)] Body 17 | | Lambda [UVar] Body 18 | | If Expr Expr Expr 19 | | Begin [Expr] Expr 20 | | Set UVar Expr 21 | | App1 ValPrim [Expr] 22 | | App2 EffectPrim [Expr] 23 | | App3 PredPrim [Expr] 24 | | App4 Expr [Expr] 25 | | UVar UVar 26 | | Quote Immediate 27 | data Body 28 | = Assigned [UVar] Expr 29 | 30 | instance PP Prog where 31 | pp (Expr e) = (pp e) 32 | ppp (Expr e) = (ppp e) 33 | instance PP Expr where 34 | pp (Let l b) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp b)]) 35 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp b)]) 36 | pp (Lambda l b) = (ppSexp [fromByteString "lambda",(ppSexp (map pp l)),(pp b)]) 37 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 38 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 39 | pp (Set u e) = (ppSexp [fromByteString "set!",(pp u),(pp e)]) 40 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 41 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 42 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 43 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 44 | pp (UVar u) = (pp u) 45 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 46 | ppp (Let l b) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp b)]) 47 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp b)]) 48 | ppp (Lambda l b) = (pppSexp [text "lambda",(pppSexp (map ppp l)),(ppp b)]) 49 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 50 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 51 | ppp (Set u e) = (pppSexp [text "set!",(ppp u),(ppp e)]) 52 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 53 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 54 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 55 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 56 | ppp (UVar u) = (ppp u) 57 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 58 | instance PP Body where 59 | pp (Assigned l e) = (ppSexp [fromByteString "assigned",(ppSexp (map pp l)),(pp e)]) 60 | ppp (Assigned l e) = (pppSexp [text "assigned",(pppSexp (map ppp l)),(ppp e)]) 61 | 62 | deriving instance Eq Prog 63 | deriving instance Read Prog 64 | deriving instance Show Prog 65 | deriving instance Ord Prog 66 | deriving instance Eq Expr 67 | deriving instance Read Expr 68 | deriving instance Show Expr 69 | deriving instance Ord Expr 70 | deriving instance Eq Body 71 | deriving instance Read Body 72 | deriving instance Show Body 73 | deriving instance Ord Body 74 | 75 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L04PurifyLetrec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L04PurifyLetrec where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Expr Expr 14 | data Expr 15 | = Let [(UVar,Expr)] Body 16 | | If Expr Expr Expr 17 | | Begin [Expr] Expr 18 | | Set UVar Expr 19 | | App1 ValPrim [Expr] 20 | | App2 EffectPrim [Expr] 21 | | App3 PredPrim [Expr] 22 | | App4 Expr [Expr] 23 | | UVar UVar 24 | | Quote Immediate 25 | | Letrec [(UVar,Lamb)] Body 26 | data Body 27 | = Assigned [UVar] Expr 28 | data Lamb 29 | = Lambda [UVar] Body 30 | 31 | instance PP Prog where 32 | pp (Expr e) = (pp e) 33 | ppp (Expr e) = (ppp e) 34 | instance PP Expr where 35 | pp (Let l b) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp b)]) 36 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 37 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 38 | pp (Set u e) = (ppSexp [fromByteString "set!",(pp u),(pp e)]) 39 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 40 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 41 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 42 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 43 | pp (UVar u) = (pp u) 44 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 45 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp b)]) 46 | ppp (Let l b) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp b)]) 47 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 48 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 49 | ppp (Set u e) = (pppSexp [text "set!",(ppp u),(ppp e)]) 50 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 51 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 52 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 53 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 54 | ppp (UVar u) = (ppp u) 55 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 56 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp b)]) 57 | instance PP Body where 58 | pp (Assigned l e) = (ppSexp [fromByteString "assigned",(ppSexp (map pp l)),(pp e)]) 59 | ppp (Assigned l e) = (pppSexp [text "assigned",(pppSexp (map ppp l)),(ppp e)]) 60 | instance PP Lamb where 61 | pp (Lambda l b) = (ppSexp [fromByteString "lambda",(ppSexp (map pp l)),(pp b)]) 62 | ppp (Lambda l b) = (pppSexp [text "lambda",(pppSexp (map ppp l)),(ppp b)]) 63 | 64 | deriving instance Eq Prog 65 | deriving instance Read Prog 66 | deriving instance Show Prog 67 | deriving instance Ord Prog 68 | deriving instance Eq Expr 69 | deriving instance Read Expr 70 | deriving instance Show Expr 71 | deriving instance Ord Expr 72 | deriving instance Eq Body 73 | deriving instance Read Body 74 | deriving instance Show Body 75 | deriving instance Ord Body 76 | deriving instance Eq Lamb 77 | deriving instance Read Lamb 78 | deriving instance Show Lamb 79 | deriving instance Ord Lamb 80 | 81 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L05ConvertAssignments.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L05ConvertAssignments where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Expr Expr 14 | data Expr 15 | = If Expr Expr Expr 16 | | Begin [Expr] Expr 17 | | App1 ValPrim [Expr] 18 | | App2 EffectPrim [Expr] 19 | | App3 PredPrim [Expr] 20 | | App4 Expr [Expr] 21 | | UVar UVar 22 | | Quote Immediate 23 | | Let [(UVar,Expr)] Expr 24 | | Letrec [(UVar,Lamb)] Expr 25 | data Lamb 26 | = Lambda [UVar] Expr 27 | 28 | instance PP Prog where 29 | pp (Expr e) = (pp e) 30 | ppp (Expr e) = (ppp e) 31 | instance PP Expr where 32 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 33 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 34 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 35 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 36 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 37 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 38 | pp (UVar u) = (pp u) 39 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 40 | pp (Let l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp e)]) 41 | pp (Letrec l e) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp e)]) 42 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 43 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 44 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 45 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 46 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 47 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 48 | ppp (UVar u) = (ppp u) 49 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 50 | ppp (Let l e) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp e)]) 51 | ppp (Letrec l e) = (pppSexp [text "letrec",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp e)]) 52 | instance PP Lamb where 53 | pp (Lambda l e) = (ppSexp [fromByteString "lambda",(ppSexp (map pp l)),(pp e)]) 54 | ppp (Lambda l e) = (pppSexp [text "lambda",(pppSexp (map ppp l)),(ppp e)]) 55 | 56 | deriving instance Eq Prog 57 | deriving instance Read Prog 58 | deriving instance Show Prog 59 | deriving instance Ord Prog 60 | deriving instance Eq Expr 61 | deriving instance Read Expr 62 | deriving instance Show Expr 63 | deriving instance Ord Expr 64 | deriving instance Eq Lamb 65 | deriving instance Read Lamb 66 | deriving instance Show Lamb 67 | deriving instance Ord Lamb 68 | 69 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L07RemoveAnonymousLambda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L07RemoveAnonymousLambda where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = ExprP Expr 14 | data Expr 15 | = If Expr Expr Expr 16 | | Begin [Expr] Expr 17 | | App1 ValPrim [Expr] 18 | | App2 EffectPrim [Expr] 19 | | App3 PredPrim [Expr] 20 | | App4 Expr [Expr] 21 | | UVar UVar 22 | | Quote Immediate 23 | | Letrec [(UVar,Lamb)] Expr 24 | | Let [(UVar,LambdaOrExpr)] Expr 25 | data Lamb 26 | = Lambda [UVar] Expr 27 | data LambdaOrExpr 28 | = Lamb Lamb 29 | | ExprL Expr 30 | 31 | instance PP Prog where 32 | pp (ExprP e) = (pp e) 33 | ppp (ExprP e) = (ppp e) 34 | instance PP Expr where 35 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 36 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 37 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 38 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 39 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 40 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 41 | pp (UVar u) = (pp u) 42 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 43 | pp (Letrec l e) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp e)]) 44 | pp (Let l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp e)]) 45 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 46 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 47 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 48 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 49 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 50 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 51 | ppp (UVar u) = (ppp u) 52 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 53 | ppp (Letrec l e) = (pppSexp [text "letrec",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp e)]) 54 | ppp (Let l e) = (pppSexp [text "let",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp e)]) 55 | instance PP Lamb where 56 | pp (Lambda l e) = (ppSexp [fromByteString "lambda",(ppSexp (map pp l)),(pp e)]) 57 | ppp (Lambda l e) = (pppSexp [text "lambda",(pppSexp (map ppp l)),(ppp e)]) 58 | instance PP LambdaOrExpr where 59 | pp (Lamb l) = (pp l) 60 | pp (ExprL e) = (pp e) 61 | ppp (Lamb l) = (ppp l) 62 | ppp (ExprL e) = (ppp e) 63 | 64 | deriving instance Eq Prog 65 | deriving instance Read Prog 66 | deriving instance Show Prog 67 | deriving instance Ord Prog 68 | deriving instance Eq Expr 69 | deriving instance Read Expr 70 | deriving instance Show Expr 71 | deriving instance Ord Expr 72 | deriving instance Eq Lamb 73 | deriving instance Read Lamb 74 | deriving instance Show Lamb 75 | deriving instance Ord Lamb 76 | deriving instance Eq LambdaOrExpr 77 | deriving instance Read LambdaOrExpr 78 | deriving instance Show LambdaOrExpr 79 | deriving instance Ord LambdaOrExpr 80 | 81 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L08SanitizeBindings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L08SanitizeBindings where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Expr Expr 14 | data Expr 15 | = If Expr Expr Expr 16 | | Begin [Expr] Expr 17 | | App1 ValPrim [Expr] 18 | | App2 EffectPrim [Expr] 19 | | App3 PredPrim [Expr] 20 | | App4 Expr [Expr] 21 | | UVar UVar 22 | | Quote Immediate 23 | | Let [(UVar,Expr)] Expr 24 | | Letrec [(UVar,[UVar],Expr)] Expr 25 | 26 | instance PP Prog where 27 | pp (Expr e) = (pp e) 28 | ppp (Expr e) = (ppp e) 29 | instance PP Expr where 30 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 31 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 32 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 33 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 34 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 35 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 36 | pp (UVar u) = (pp u) 37 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 38 | pp (Let l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp e)]) 39 | pp (Letrec l e) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(u,l,e) -> (ppSexp [(pp u),(ppSexp [fromByteString "lambda",(ppSexp (map pp l)),(pp e)])])) l)),(pp e)]) 40 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 41 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 42 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 43 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 44 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 45 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 46 | ppp (UVar u) = (ppp u) 47 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 48 | ppp (Let l e) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp e)]) 49 | ppp (Letrec l e) = (pppSexp [text "letrec",(pppSexp (map (\(u,l,e) -> (pppSexp [(ppp u),(pppSexp [text "lambda",(pppSexp (map ppp l)),(ppp e)])])) l)),(ppp e)]) 50 | 51 | deriving instance Eq Prog 52 | deriving instance Read Prog 53 | deriving instance Show Prog 54 | deriving instance Ord Prog 55 | deriving instance Eq Expr 56 | deriving instance Read Expr 57 | deriving instance Show Expr 58 | deriving instance Ord Expr 59 | 60 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L09UncoverFree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L09UncoverFree where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Expr Expr 14 | data Expr 15 | = If Expr Expr Expr 16 | | Begin [Expr] Expr 17 | | App1 ValPrim [Expr] 18 | | App2 EffectPrim [Expr] 19 | | App3 PredPrim [Expr] 20 | | App4 Expr [Expr] 21 | | UVar UVar 22 | | Quote Immediate 23 | | Let [(UVar,Expr)] Expr 24 | | Letrec [(UVar,[UVar],[UVar],Expr)] Expr 25 | 26 | instance PP Prog where 27 | pp (Expr e) = (pp e) 28 | ppp (Expr e) = (ppp e) 29 | instance PP Expr where 30 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 31 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 32 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 33 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 34 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 35 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 36 | pp (UVar u) = (pp u) 37 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 38 | pp (Let l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp e)]) 39 | pp (Letrec l e) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(u,l,l2,e) -> (ppSexp [(pp u),(ppSexp [fromByteString "lambda",(ppSexp (map pp l)),(ppSexp [fromByteString "free",(ppSexp (map pp l2)),(pp e)])])])) l)),(pp e)]) 40 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 41 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 42 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 43 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 44 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 45 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 46 | ppp (UVar u) = (ppp u) 47 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 48 | ppp (Let l e) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp e)]) 49 | ppp (Letrec l e) = (pppSexp [text "letrec",(pppSexp (map (\(u,l,l2,e) -> (pppSexp [(ppp u),(pppSexp [text "lambda",(pppSexp (map ppp l)),(pppSexp [text "free",(pppSexp (map ppp l2)),(ppp e)])])])) l)),(ppp e)]) 50 | 51 | deriving instance Eq Prog 52 | deriving instance Read Prog 53 | deriving instance Show Prog 54 | deriving instance Ord Prog 55 | deriving instance Eq Expr 56 | deriving instance Read Expr 57 | deriving instance Show Expr 58 | deriving instance Ord Expr 59 | 60 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L10ConvertClosures.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L10ConvertClosures where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Expr Expr 14 | data Expr 15 | = If Expr Expr Expr 16 | | Begin [Expr] Expr 17 | | App1 ValPrim [Expr] 18 | | App2 EffectPrim [Expr] 19 | | App3 PredPrim [Expr] 20 | | App4 Expr [Expr] 21 | | UVar UVar 22 | | Quote Immediate 23 | | Let [(UVar,Expr)] Expr 24 | | Letrec [(Label,[UVar],[UVar],Expr)] [(UVar,Label,[UVar])] Expr 25 | | Label Label 26 | 27 | instance PP Prog where 28 | pp (Expr e) = (pp e) 29 | ppp (Expr e) = (ppp e) 30 | instance PP Expr where 31 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 32 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 33 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 34 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 35 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 36 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 37 | pp (UVar u) = (pp u) 38 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 39 | pp (Let l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp e)]) 40 | pp (Letrec l l2 e) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,l3,e) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(ppSexp [fromByteString "bind-free",(ppSexp (map pp l3)),(pp e)])])])) l)),(ppSexp [fromByteString "closures",(ppSexp (map (\(u,l,l2) -> (ppSexp ((pp u) : ((pp l) : (map pp l2))))) l2)),(pp e)])]) 41 | pp (Label l) = (pp l) 42 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 43 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 44 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 45 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 46 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 47 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 48 | ppp (UVar u) = (ppp u) 49 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 50 | ppp (Let l e) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp e)]) 51 | ppp (Letrec l l2 e) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,l3,e) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(pppSexp [text "bind-free",(pppSexp (map ppp l3)),(ppp e)])])])) l)),(pppSexp [text "closures",(pppSexp (map (\(u,l,l2) -> (pppSexp ((ppp u) : ((ppp l) : (map ppp l2))))) l2)),(ppp e)])]) 52 | ppp (Label l) = (ppp l) 53 | 54 | deriving instance Eq Prog 55 | deriving instance Read Prog 56 | deriving instance Show Prog 57 | deriving instance Ord Prog 58 | deriving instance Eq Expr 59 | deriving instance Read Expr 60 | deriving instance Show Expr 61 | deriving instance Ord Expr 62 | 63 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L12UncoverWellKnown.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L12UncoverWellKnown where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Expr Expr 14 | data Expr 15 | = If Expr Expr Expr 16 | | Begin [Expr] Expr 17 | | App1 ValPrim [Expr] 18 | | App2 EffectPrim [Expr] 19 | | App3 PredPrim [Expr] 20 | | App4 Expr [Expr] 21 | | UVar UVar 22 | | Quote Immediate 23 | | Let [(UVar,Expr)] Expr 24 | | Label Label 25 | | Letrec [(Label,[UVar],[UVar],Expr)] [(UVar,Label,[UVar])] [UVar] Expr 26 | 27 | instance PP Prog where 28 | pp (Expr e) = (pp e) 29 | ppp (Expr e) = (ppp e) 30 | instance PP Expr where 31 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 32 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 33 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 34 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 35 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 36 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 37 | pp (UVar u) = (pp u) 38 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 39 | pp (Let l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp e)]) 40 | pp (Label l) = (pp l) 41 | pp (Letrec l l2 l3 e) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,l3,e) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(ppSexp [fromByteString "bind-free",(ppSexp (map pp l3)),(pp e)])])])) l)),(ppSexp [fromByteString "closures",(ppSexp (map (\(u,l,l2) -> (ppSexp ((pp u) : ((pp l) : (map pp l2))))) l2)),(ppSexp [fromByteString "well-known",(ppSexp (map pp l3)),(pp e)])])]) 42 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 43 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 44 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 45 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 46 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 47 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 48 | ppp (UVar u) = (ppp u) 49 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 50 | ppp (Let l e) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp e)]) 51 | ppp (Label l) = (ppp l) 52 | ppp (Letrec l l2 l3 e) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,l3,e) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(pppSexp [text "bind-free",(pppSexp (map ppp l3)),(ppp e)])])])) l)),(pppSexp [text "closures",(pppSexp (map (\(u,l,l2) -> (pppSexp ((ppp u) : ((ppp l) : (map ppp l2))))) l2)),(pppSexp [text "well-known",(pppSexp (map ppp l3)),(ppp e)])])]) 53 | 54 | deriving instance Eq Prog 55 | deriving instance Read Prog 56 | deriving instance Show Prog 57 | deriving instance Ord Prog 58 | deriving instance Eq Expr 59 | deriving instance Read Expr 60 | deriving instance Show Expr 61 | deriving instance Ord Expr 62 | 63 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L15IntroduceProcedurePrimitives.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L15IntroduceProcedurePrimitives where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Expr Expr 14 | data Expr 15 | = If Expr Expr Expr 16 | | Begin [Expr] Expr 17 | | App1 ValPrim [Expr] 18 | | App2 EffectPrim [Expr] 19 | | App3 PredPrim [Expr] 20 | | App4 Expr [Expr] 21 | | UVar UVar 22 | | Quote Immediate 23 | | Let [(UVar,Expr)] Expr 24 | | Label Label 25 | | Letrec [(Label,[UVar],Expr)] Expr 26 | 27 | instance PP Prog where 28 | pp (Expr e) = (pp e) 29 | ppp (Expr e) = (ppp e) 30 | instance PP Expr where 31 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 32 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 33 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 34 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 35 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 36 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 37 | pp (UVar u) = (pp u) 38 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 39 | pp (Let l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp e)]) 40 | pp (Label l) = (pp l) 41 | pp (Letrec l e) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,e) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(pp e)])])) l)),(pp e)]) 42 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 43 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 44 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 45 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 46 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 47 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 48 | ppp (UVar u) = (ppp u) 49 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 50 | ppp (Let l e) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp e)]) 51 | ppp (Label l) = (ppp l) 52 | ppp (Letrec l e) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,e) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(ppp e)])])) l)),(ppp e)]) 53 | 54 | deriving instance Eq Prog 55 | deriving instance Read Prog 56 | deriving instance Show Prog 57 | deriving instance Ord Prog 58 | deriving instance Eq Expr 59 | deriving instance Read Expr 60 | deriving instance Show Expr 61 | deriving instance Ord Expr 62 | 63 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L17LiftLetrec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L17LiftLetrec where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Expr 13 | = If Expr Expr Expr 14 | | Begin [Expr] Expr 15 | | App1 ValPrim [Expr] 16 | | App2 EffectPrim [Expr] 17 | | App3 PredPrim [Expr] 18 | | App4 Expr [Expr] 19 | | UVar UVar 20 | | Quote Immediate 21 | | Let [(UVar,Expr)] Expr 22 | | Label Label 23 | data Prog 24 | = Letrec [(Label,[UVar],Expr)] Expr 25 | 26 | instance PP Expr where 27 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 28 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 29 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 30 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 31 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 32 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 33 | pp (UVar u) = (pp u) 34 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 35 | pp (Let l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)),(pp e)]) 36 | pp (Label l) = (pp l) 37 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 38 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 39 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 40 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 41 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 42 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 43 | ppp (UVar u) = (ppp u) 44 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 45 | ppp (Let l e) = (pppSexp [text "let",(pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)),(ppp e)]) 46 | ppp (Label l) = (ppp l) 47 | instance PP Prog where 48 | pp (Letrec l e) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,e) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(pp e)])])) l)),(pp e)]) 49 | ppp (Letrec l e) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,e) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(ppp e)])])) l)),(ppp e)]) 50 | 51 | deriving instance Eq Expr 52 | deriving instance Read Expr 53 | deriving instance Show Expr 54 | deriving instance Ord Expr 55 | deriving instance Eq Prog 56 | deriving instance Read Prog 57 | deriving instance Show Prog 58 | deriving instance Ord Prog 59 | 60 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L18NormalizeContext.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L18NormalizeContext where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Letrec [(Label,[UVar],Value)] Value 14 | data Pred 15 | = LetP [(UVar,Value)] Pred 16 | | TrueP 17 | | FalseP 18 | | IfP Pred Pred Pred 19 | | BeginP [Effect] Pred 20 | | AppP PredPrim [Value] 21 | data Effect 22 | = LetE [(UVar,Value)] Effect 23 | | Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | AppE1 EffectPrim [Value] 27 | | AppE2 Value [Value] 28 | data Value 29 | = Quote Immediate 30 | | LetV [(UVar,Value)] Value 31 | | IfV Pred Value Value 32 | | BeginV [Effect] Value 33 | | AppV1 ValPrim [Value] 34 | | AppV2 Value [Value] 35 | | UVar UVar 36 | | Label Label 37 | 38 | instance PP Prog where 39 | pp (Letrec l v) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,v) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(pp v)])])) l)),(pp v)]) 40 | ppp (Letrec l v) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,v) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(ppp v)])])) l)),(ppp v)]) 41 | instance PP Pred where 42 | pp (LetP l p) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,v) -> (ppSexp [(pp u),(pp v)])) l)),(pp p)]) 43 | pp (TrueP) = (ppSexp [fromByteString "true"]) 44 | pp (FalseP) = (ppSexp [fromByteString "false"]) 45 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 46 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 47 | pp (AppP p l) = (ppSexp ((pp p) : (map pp l))) 48 | ppp (LetP l p) = (pppSexp [text "let",(pppSexp (map (\(u,v) -> (pppSexp [(ppp u),(ppp v)])) l)),(ppp p)]) 49 | ppp (TrueP) = (pppSexp [text "true"]) 50 | ppp (FalseP) = (pppSexp [text "false"]) 51 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 52 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 53 | ppp (AppP p l) = (pppSexp ((ppp p) : (map ppp l))) 54 | instance PP Effect where 55 | pp (LetE l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,v) -> (ppSexp [(pp u),(pp v)])) l)),(pp e)]) 56 | pp (Nop) = (ppSexp [fromByteString "nop"]) 57 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 58 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 59 | pp (AppE1 e l) = (ppSexp ((pp e) : (map pp l))) 60 | pp (AppE2 v l) = (ppSexp ((pp v) : (map pp l))) 61 | ppp (LetE l e) = (pppSexp [text "let",(pppSexp (map (\(u,v) -> (pppSexp [(ppp u),(ppp v)])) l)),(ppp e)]) 62 | ppp (Nop) = (pppSexp [text "nop"]) 63 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 64 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 65 | ppp (AppE1 e l) = (pppSexp ((ppp e) : (map ppp l))) 66 | ppp (AppE2 v l) = (pppSexp ((ppp v) : (map ppp l))) 67 | instance PP Value where 68 | pp (Quote i) = (ppSexp [fromByteString "quote",(pp i)]) 69 | pp (LetV l v) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,v) -> (ppSexp [(pp u),(pp v)])) l)),(pp v)]) 70 | pp (IfV p v v2) = (ppSexp [fromByteString "if",(pp p),(pp v),(pp v2)]) 71 | pp (BeginV l v) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp v)]))) 72 | pp (AppV1 v l) = (ppSexp ((pp v) : (map pp l))) 73 | pp (AppV2 v l) = (ppSexp ((pp v) : (map pp l))) 74 | pp (UVar u) = (pp u) 75 | pp (Label l) = (pp l) 76 | ppp (Quote i) = (pppSexp [text "quote",(ppp i)]) 77 | ppp (LetV l v) = (pppSexp [text "let",(pppSexp (map (\(u,v) -> (pppSexp [(ppp u),(ppp v)])) l)),(ppp v)]) 78 | ppp (IfV p v v2) = (pppSexp [text "if",(ppp p),(ppp v),(ppp v2)]) 79 | ppp (BeginV l v) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp v)]))) 80 | ppp (AppV1 v l) = (pppSexp ((ppp v) : (map ppp l))) 81 | ppp (AppV2 v l) = (pppSexp ((ppp v) : (map ppp l))) 82 | ppp (UVar u) = (ppp u) 83 | ppp (Label l) = (ppp l) 84 | 85 | deriving instance Eq Prog 86 | deriving instance Read Prog 87 | deriving instance Show Prog 88 | deriving instance Ord Prog 89 | deriving instance Eq Pred 90 | deriving instance Read Pred 91 | deriving instance Show Pred 92 | deriving instance Ord Pred 93 | deriving instance Eq Effect 94 | deriving instance Read Effect 95 | deriving instance Show Effect 96 | deriving instance Ord Effect 97 | deriving instance Eq Value 98 | deriving instance Read Value 99 | deriving instance Show Value 100 | deriving instance Ord Value 101 | 102 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L19SpecifyRepresentation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L19SpecifyRepresentation where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = Letrec [(Label,[UVar],Tail)] Tail 14 | data Tail 15 | = LetT [(UVar,Value)] Tail 16 | | IfT Pred Tail Tail 17 | | BeginT [Effect] Tail 18 | | AllocT Value 19 | | MrefT Value Value 20 | | AppT1 Binop Value Value 21 | | AppT2 Value [Value] 22 | | TrivT Triv 23 | data Pred 24 | = LetP [(UVar,Value)] Pred 25 | | TrueP 26 | | FalseP 27 | | IfP Pred Pred Pred 28 | | BeginP [Effect] Pred 29 | | AppP Relop Value Value 30 | data Effect 31 | = LetE [(UVar,Value)] Effect 32 | | Nop 33 | | Mset Value Value Value 34 | | IfE Pred Effect Effect 35 | | BeginE [Effect] Effect 36 | | AppE Value [Value] 37 | data Value 38 | = LetV [(UVar,Value)] Value 39 | | IfV Pred Value Value 40 | | BeginV [Effect] Value 41 | | AllocV Value 42 | | MrefV Value Value 43 | | AppV1 Binop Value Value 44 | | AppV2 Value [Value] 45 | | TrivV Triv 46 | data Triv 47 | = UVar UVar 48 | | Integer Integer 49 | | Label Label 50 | 51 | instance PP Prog where 52 | pp (Letrec l t) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,t) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(pp t)])])) l)),(pp t)]) 53 | ppp (Letrec l t) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,t) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(ppp t)])])) l)),(ppp t)]) 54 | instance PP Tail where 55 | pp (LetT l t) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,v) -> (ppSexp [(pp u),(pp v)])) l)),(pp t)]) 56 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 57 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 58 | pp (AllocT v) = (ppSexp [fromByteString "alloc",(pp v)]) 59 | pp (MrefT v v2) = (ppSexp [fromByteString "mref",(pp v),(pp v2)]) 60 | pp (AppT1 b v v2) = (ppSexp [(pp b),(pp v),(pp v2)]) 61 | pp (AppT2 v l) = (ppSexp ((pp v) : (map pp l))) 62 | pp (TrivT t) = (pp t) 63 | ppp (LetT l t) = (pppSexp [text "let",(pppSexp (map (\(u,v) -> (pppSexp [(ppp u),(ppp v)])) l)),(ppp t)]) 64 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 65 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 66 | ppp (AllocT v) = (pppSexp [text "alloc",(ppp v)]) 67 | ppp (MrefT v v2) = (pppSexp [text "mref",(ppp v),(ppp v2)]) 68 | ppp (AppT1 b v v2) = (pppSexp [(ppp b),(ppp v),(ppp v2)]) 69 | ppp (AppT2 v l) = (pppSexp ((ppp v) : (map ppp l))) 70 | ppp (TrivT t) = (ppp t) 71 | instance PP Pred where 72 | pp (LetP l p) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,v) -> (ppSexp [(pp u),(pp v)])) l)),(pp p)]) 73 | pp (TrueP) = (ppSexp [fromByteString "true"]) 74 | pp (FalseP) = (ppSexp [fromByteString "false"]) 75 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 76 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 77 | pp (AppP r v v2) = (ppSexp [(pp r),(pp v),(pp v2)]) 78 | ppp (LetP l p) = (pppSexp [text "let",(pppSexp (map (\(u,v) -> (pppSexp [(ppp u),(ppp v)])) l)),(ppp p)]) 79 | ppp (TrueP) = (pppSexp [text "true"]) 80 | ppp (FalseP) = (pppSexp [text "false"]) 81 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 82 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 83 | ppp (AppP r v v2) = (pppSexp [(ppp r),(ppp v),(ppp v2)]) 84 | instance PP Effect where 85 | pp (LetE l e) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,v) -> (ppSexp [(pp u),(pp v)])) l)),(pp e)]) 86 | pp (Nop) = (ppSexp [fromByteString "nop"]) 87 | pp (Mset v v2 v3) = (ppSexp [fromByteString "mset!",(pp v),(pp v2),(pp v3)]) 88 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 89 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 90 | pp (AppE v l) = (ppSexp ((pp v) : (map pp l))) 91 | ppp (LetE l e) = (pppSexp [text "let",(pppSexp (map (\(u,v) -> (pppSexp [(ppp u),(ppp v)])) l)),(ppp e)]) 92 | ppp (Nop) = (pppSexp [text "nop"]) 93 | ppp (Mset v v2 v3) = (pppSexp [text "mset!",(ppp v),(ppp v2),(ppp v3)]) 94 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 95 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 96 | ppp (AppE v l) = (pppSexp ((ppp v) : (map ppp l))) 97 | instance PP Value where 98 | pp (LetV l v) = (ppSexp [fromByteString "let",(ppSexp (map (\(u,v) -> (ppSexp [(pp u),(pp v)])) l)),(pp v)]) 99 | pp (IfV p v v2) = (ppSexp [fromByteString "if",(pp p),(pp v),(pp v2)]) 100 | pp (BeginV l v) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp v)]))) 101 | pp (AllocV v) = (ppSexp [fromByteString "alloc",(pp v)]) 102 | pp (MrefV v v2) = (ppSexp [fromByteString "mref",(pp v),(pp v2)]) 103 | pp (AppV1 b v v2) = (ppSexp [(pp b),(pp v),(pp v2)]) 104 | pp (AppV2 v l) = (ppSexp ((pp v) : (map pp l))) 105 | pp (TrivV t) = (pp t) 106 | ppp (LetV l v) = (pppSexp [text "let",(pppSexp (map (\(u,v) -> (pppSexp [(ppp u),(ppp v)])) l)),(ppp v)]) 107 | ppp (IfV p v v2) = (pppSexp [text "if",(ppp p),(ppp v),(ppp v2)]) 108 | ppp (BeginV l v) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp v)]))) 109 | ppp (AllocV v) = (pppSexp [text "alloc",(ppp v)]) 110 | ppp (MrefV v v2) = (pppSexp [text "mref",(ppp v),(ppp v2)]) 111 | ppp (AppV1 b v v2) = (pppSexp [(ppp b),(ppp v),(ppp v2)]) 112 | ppp (AppV2 v l) = (pppSexp ((ppp v) : (map ppp l))) 113 | ppp (TrivV t) = (ppp t) 114 | instance PP Triv where 115 | pp (UVar u) = (pp u) 116 | pp (Integer i) = (pp i) 117 | pp (Label l) = (pp l) 118 | ppp (UVar u) = (ppp u) 119 | ppp (Integer i) = (ppp i) 120 | ppp (Label l) = (ppp l) 121 | 122 | deriving instance Eq Prog 123 | deriving instance Read Prog 124 | deriving instance Show Prog 125 | deriving instance Ord Prog 126 | deriving instance Eq Tail 127 | deriving instance Read Tail 128 | deriving instance Show Tail 129 | deriving instance Ord Tail 130 | deriving instance Eq Pred 131 | deriving instance Read Pred 132 | deriving instance Show Pred 133 | deriving instance Ord Pred 134 | deriving instance Eq Effect 135 | deriving instance Read Effect 136 | deriving instance Show Effect 137 | deriving instance Ord Effect 138 | deriving instance Eq Value 139 | deriving instance Read Value 140 | deriving instance Show Value 141 | deriving instance Ord Value 142 | deriving instance Eq Triv 143 | deriving instance Read Triv 144 | deriving instance Show Triv 145 | deriving instance Ord Triv 146 | 147 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L22VerifyUil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L22VerifyUil where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AllocT Value 16 | | MrefT Value Value 17 | | AppT1 Binop Value Value 18 | | AppT2 Value [Value] 19 | | TrivT Triv 20 | data Pred 21 | = TrueP 22 | | FalseP 23 | | IfP Pred Pred Pred 24 | | BeginP [Effect] Pred 25 | | AppP Relop Value Value 26 | data Effect 27 | = Nop 28 | | Mset Value Value Value 29 | | IfE Pred Effect Effect 30 | | BeginE [Effect] Effect 31 | | AppE Value [Value] 32 | | Set UVar Value 33 | data Value 34 | = IfV Pred Value Value 35 | | BeginV [Effect] Value 36 | | AllocV Value 37 | | MrefV Value Value 38 | | AppV1 Binop Value Value 39 | | AppV2 Value [Value] 40 | | TrivV Triv 41 | data Triv 42 | = UVar UVar 43 | | Integer Integer 44 | | Label Label 45 | data Prog 46 | = Letrec [(Label,[UVar],Body)] Body 47 | data Body 48 | = Locals [UVar] Tail 49 | 50 | instance PP Tail where 51 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 52 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 53 | pp (AllocT v) = (ppSexp [fromByteString "alloc",(pp v)]) 54 | pp (MrefT v v2) = (ppSexp [fromByteString "mref",(pp v),(pp v2)]) 55 | pp (AppT1 b v v2) = (ppSexp [(pp b),(pp v),(pp v2)]) 56 | pp (AppT2 v l) = (ppSexp ((pp v) : (map pp l))) 57 | pp (TrivT t) = (pp t) 58 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 59 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 60 | ppp (AllocT v) = (pppSexp [text "alloc",(ppp v)]) 61 | ppp (MrefT v v2) = (pppSexp [text "mref",(ppp v),(ppp v2)]) 62 | ppp (AppT1 b v v2) = (pppSexp [(ppp b),(ppp v),(ppp v2)]) 63 | ppp (AppT2 v l) = (pppSexp ((ppp v) : (map ppp l))) 64 | ppp (TrivT t) = (ppp t) 65 | instance PP Pred where 66 | pp (TrueP) = (ppSexp [fromByteString "true"]) 67 | pp (FalseP) = (ppSexp [fromByteString "false"]) 68 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 69 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 70 | pp (AppP r v v2) = (ppSexp [(pp r),(pp v),(pp v2)]) 71 | ppp (TrueP) = (pppSexp [text "true"]) 72 | ppp (FalseP) = (pppSexp [text "false"]) 73 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 74 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 75 | ppp (AppP r v v2) = (pppSexp [(ppp r),(ppp v),(ppp v2)]) 76 | instance PP Effect where 77 | pp (Nop) = (ppSexp [fromByteString "nop"]) 78 | pp (Mset v v2 v3) = (ppSexp [fromByteString "mset!",(pp v),(pp v2),(pp v3)]) 79 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 80 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 81 | pp (AppE v l) = (ppSexp ((pp v) : (map pp l))) 82 | pp (Set u v) = (ppSexp [fromByteString "set!",(pp u),(pp v)]) 83 | ppp (Nop) = (pppSexp [text "nop"]) 84 | ppp (Mset v v2 v3) = (pppSexp [text "mset!",(ppp v),(ppp v2),(ppp v3)]) 85 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 86 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 87 | ppp (AppE v l) = (pppSexp ((ppp v) : (map ppp l))) 88 | ppp (Set u v) = (pppSexp [text "set!",(ppp u),(ppp v)]) 89 | instance PP Value where 90 | pp (IfV p v v2) = (ppSexp [fromByteString "if",(pp p),(pp v),(pp v2)]) 91 | pp (BeginV l v) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp v)]))) 92 | pp (AllocV v) = (ppSexp [fromByteString "alloc",(pp v)]) 93 | pp (MrefV v v2) = (ppSexp [fromByteString "mref",(pp v),(pp v2)]) 94 | pp (AppV1 b v v2) = (ppSexp [(pp b),(pp v),(pp v2)]) 95 | pp (AppV2 v l) = (ppSexp ((pp v) : (map pp l))) 96 | pp (TrivV t) = (pp t) 97 | ppp (IfV p v v2) = (pppSexp [text "if",(ppp p),(ppp v),(ppp v2)]) 98 | ppp (BeginV l v) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp v)]))) 99 | ppp (AllocV v) = (pppSexp [text "alloc",(ppp v)]) 100 | ppp (MrefV v v2) = (pppSexp [text "mref",(ppp v),(ppp v2)]) 101 | ppp (AppV1 b v v2) = (pppSexp [(ppp b),(ppp v),(ppp v2)]) 102 | ppp (AppV2 v l) = (pppSexp ((ppp v) : (map ppp l))) 103 | ppp (TrivV t) = (ppp t) 104 | instance PP Triv where 105 | pp (UVar u) = (pp u) 106 | pp (Integer i) = (pp i) 107 | pp (Label l) = (pp l) 108 | ppp (UVar u) = (ppp u) 109 | ppp (Integer i) = (ppp i) 110 | ppp (Label l) = (ppp l) 111 | instance PP Prog where 112 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(pp b)])])) l)),(pp b)]) 113 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(ppp b)])])) l)),(ppp b)]) 114 | instance PP Body where 115 | pp (Locals l t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(pp t)]) 116 | ppp (Locals l t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(ppp t)]) 117 | 118 | deriving instance Eq Tail 119 | deriving instance Read Tail 120 | deriving instance Show Tail 121 | deriving instance Ord Tail 122 | deriving instance Eq Pred 123 | deriving instance Read Pred 124 | deriving instance Show Pred 125 | deriving instance Ord Pred 126 | deriving instance Eq Effect 127 | deriving instance Read Effect 128 | deriving instance Show Effect 129 | deriving instance Ord Effect 130 | deriving instance Eq Value 131 | deriving instance Read Value 132 | deriving instance Show Value 133 | deriving instance Ord Value 134 | deriving instance Eq Triv 135 | deriving instance Read Triv 136 | deriving instance Show Triv 137 | deriving instance Ord Triv 138 | deriving instance Eq Prog 139 | deriving instance Read Prog 140 | deriving instance Show Prog 141 | deriving instance Ord Prog 142 | deriving instance Eq Body 143 | deriving instance Read Body 144 | deriving instance Show Body 145 | deriving instance Ord Body 146 | 147 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L23RemoveComplexOpera.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L23RemoveComplexOpera where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | TrivT Triv 16 | | AllocT Triv 17 | | MrefT Triv Triv 18 | | AppT1 Binop Triv Triv 19 | | AppT2 Triv [Triv] 20 | data Pred 21 | = TrueP 22 | | FalseP 23 | | IfP Pred Pred Pred 24 | | BeginP [Effect] Pred 25 | | AppP Relop Triv Triv 26 | data Effect 27 | = Nop 28 | | IfE Pred Effect Effect 29 | | BeginE [Effect] Effect 30 | | Set UVar Value 31 | | Mset Triv Triv Triv 32 | | AppE Triv [Triv] 33 | data Value 34 | = IfV Pred Value Value 35 | | BeginV [Effect] Value 36 | | TrivV Triv 37 | | AllocV Triv 38 | | MrefV Triv Triv 39 | | AppV1 Binop Triv Triv 40 | | AppV2 Triv [Triv] 41 | data Triv 42 | = UVar UVar 43 | | Integer Integer 44 | | Label Label 45 | data Prog 46 | = Letrec [(Label,[UVar],Body)] Body 47 | data Body 48 | = Locals [UVar] Tail 49 | 50 | instance PP Tail where 51 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 52 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 53 | pp (TrivT t) = (pp t) 54 | pp (AllocT t) = (ppSexp [fromByteString "alloc",(pp t)]) 55 | pp (MrefT t t2) = (ppSexp [fromByteString "mref",(pp t),(pp t2)]) 56 | pp (AppT1 b t t2) = (ppSexp [(pp b),(pp t),(pp t2)]) 57 | pp (AppT2 t l) = (ppSexp ((pp t) : (map pp l))) 58 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 59 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 60 | ppp (TrivT t) = (ppp t) 61 | ppp (AllocT t) = (pppSexp [text "alloc",(ppp t)]) 62 | ppp (MrefT t t2) = (pppSexp [text "mref",(ppp t),(ppp t2)]) 63 | ppp (AppT1 b t t2) = (pppSexp [(ppp b),(ppp t),(ppp t2)]) 64 | ppp (AppT2 t l) = (pppSexp ((ppp t) : (map ppp l))) 65 | instance PP Pred where 66 | pp (TrueP) = (ppSexp [fromByteString "true"]) 67 | pp (FalseP) = (ppSexp [fromByteString "false"]) 68 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 69 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 70 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 71 | ppp (TrueP) = (pppSexp [text "true"]) 72 | ppp (FalseP) = (pppSexp [text "false"]) 73 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 74 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 75 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 76 | instance PP Effect where 77 | pp (Nop) = (ppSexp [fromByteString "nop"]) 78 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 79 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 80 | pp (Set u v) = (ppSexp [fromByteString "set!",(pp u),(pp v)]) 81 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 82 | pp (AppE t l) = (ppSexp ((pp t) : (map pp l))) 83 | ppp (Nop) = (pppSexp [text "nop"]) 84 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 85 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 86 | ppp (Set u v) = (pppSexp [text "set!",(ppp u),(ppp v)]) 87 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 88 | ppp (AppE t l) = (pppSexp ((ppp t) : (map ppp l))) 89 | instance PP Value where 90 | pp (IfV p v v2) = (ppSexp [fromByteString "if",(pp p),(pp v),(pp v2)]) 91 | pp (BeginV l v) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp v)]))) 92 | pp (TrivV t) = (pp t) 93 | pp (AllocV t) = (ppSexp [fromByteString "alloc",(pp t)]) 94 | pp (MrefV t t2) = (ppSexp [fromByteString "mref",(pp t),(pp t2)]) 95 | pp (AppV1 b t t2) = (ppSexp [(pp b),(pp t),(pp t2)]) 96 | pp (AppV2 t l) = (ppSexp ((pp t) : (map pp l))) 97 | ppp (IfV p v v2) = (pppSexp [text "if",(ppp p),(ppp v),(ppp v2)]) 98 | ppp (BeginV l v) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp v)]))) 99 | ppp (TrivV t) = (ppp t) 100 | ppp (AllocV t) = (pppSexp [text "alloc",(ppp t)]) 101 | ppp (MrefV t t2) = (pppSexp [text "mref",(ppp t),(ppp t2)]) 102 | ppp (AppV1 b t t2) = (pppSexp [(ppp b),(ppp t),(ppp t2)]) 103 | ppp (AppV2 t l) = (pppSexp ((ppp t) : (map ppp l))) 104 | instance PP Triv where 105 | pp (UVar u) = (pp u) 106 | pp (Integer i) = (pp i) 107 | pp (Label l) = (pp l) 108 | ppp (UVar u) = (ppp u) 109 | ppp (Integer i) = (ppp i) 110 | ppp (Label l) = (ppp l) 111 | instance PP Prog where 112 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(pp b)])])) l)),(pp b)]) 113 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(ppp b)])])) l)),(ppp b)]) 114 | instance PP Body where 115 | pp (Locals l t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(pp t)]) 116 | ppp (Locals l t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(ppp t)]) 117 | 118 | deriving instance Eq Tail 119 | deriving instance Read Tail 120 | deriving instance Show Tail 121 | deriving instance Ord Tail 122 | deriving instance Eq Pred 123 | deriving instance Read Pred 124 | deriving instance Show Pred 125 | deriving instance Ord Pred 126 | deriving instance Eq Effect 127 | deriving instance Read Effect 128 | deriving instance Show Effect 129 | deriving instance Ord Effect 130 | deriving instance Eq Value 131 | deriving instance Read Value 132 | deriving instance Show Value 133 | deriving instance Ord Value 134 | deriving instance Eq Triv 135 | deriving instance Read Triv 136 | deriving instance Show Triv 137 | deriving instance Ord Triv 138 | deriving instance Eq Prog 139 | deriving instance Read Prog 140 | deriving instance Show Prog 141 | deriving instance Ord Prog 142 | deriving instance Eq Body 143 | deriving instance Read Body 144 | deriving instance Show Body 145 | deriving instance Ord Body 146 | 147 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L24FlattenSet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L24FlattenSet where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | Triv Triv 16 | | Alloc Triv 17 | | Mref Triv Triv 18 | | AppT1 Binop Triv Triv 19 | | AppT2 Triv [Triv] 20 | data Pred 21 | = TrueP 22 | | FalseP 23 | | IfP Pred Pred Pred 24 | | BeginP [Effect] Pred 25 | | AppP Relop Triv Triv 26 | data Effect 27 | = Nop 28 | | IfE Pred Effect Effect 29 | | BeginE [Effect] Effect 30 | | Mset Triv Triv Triv 31 | | AppE Triv [Triv] 32 | | Set1 UVar Triv 33 | | Set2 UVar Binop Triv Triv 34 | | Set3 UVar Triv [Triv] 35 | | Set4 UVar Triv 36 | | Set5 UVar Triv Triv 37 | data Triv 38 | = UVar UVar 39 | | Integer Integer 40 | | Label Label 41 | data Prog 42 | = Letrec [(Label,[UVar],Body)] Body 43 | data Body 44 | = Locals [UVar] Tail 45 | 46 | instance PP Tail where 47 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 48 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 49 | pp (Triv t) = (pp t) 50 | pp (Alloc t) = (ppSexp [fromByteString "alloc",(pp t)]) 51 | pp (Mref t t2) = (ppSexp [fromByteString "mref",(pp t),(pp t2)]) 52 | pp (AppT1 b t t2) = (ppSexp [(pp b),(pp t),(pp t2)]) 53 | pp (AppT2 t l) = (ppSexp ((pp t) : (map pp l))) 54 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 55 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 56 | ppp (Triv t) = (ppp t) 57 | ppp (Alloc t) = (pppSexp [text "alloc",(ppp t)]) 58 | ppp (Mref t t2) = (pppSexp [text "mref",(ppp t),(ppp t2)]) 59 | ppp (AppT1 b t t2) = (pppSexp [(ppp b),(ppp t),(ppp t2)]) 60 | ppp (AppT2 t l) = (pppSexp ((ppp t) : (map ppp l))) 61 | instance PP Pred where 62 | pp (TrueP) = (ppSexp [fromByteString "true"]) 63 | pp (FalseP) = (ppSexp [fromByteString "false"]) 64 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 65 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 66 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 67 | ppp (TrueP) = (pppSexp [text "true"]) 68 | ppp (FalseP) = (pppSexp [text "false"]) 69 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 70 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 71 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 72 | instance PP Effect where 73 | pp (Nop) = (ppSexp [fromByteString "nop"]) 74 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 75 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 76 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 77 | pp (AppE t l) = (ppSexp ((pp t) : (map pp l))) 78 | pp (Set1 u t) = (ppSexp [fromByteString "set!",(pp u),(pp t)]) 79 | pp (Set2 u b t t2) = (ppSexp [fromByteString "set!",(pp u),(ppSexp [(pp b),(pp t),(pp t2)])]) 80 | pp (Set3 u t l) = (ppSexp [fromByteString "set!",(pp u),(ppSexp ((pp t) : (map pp l)))]) 81 | pp (Set4 u t) = (ppSexp [fromByteString "set!",(pp u),(ppSexp [fromByteString "alloc",(pp t)])]) 82 | pp (Set5 u t t2) = (ppSexp [fromByteString "set!",(pp u),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 83 | ppp (Nop) = (pppSexp [text "nop"]) 84 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 85 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 86 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 87 | ppp (AppE t l) = (pppSexp ((ppp t) : (map ppp l))) 88 | ppp (Set1 u t) = (pppSexp [text "set!",(ppp u),(ppp t)]) 89 | ppp (Set2 u b t t2) = (pppSexp [text "set!",(ppp u),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 90 | ppp (Set3 u t l) = (pppSexp [text "set!",(ppp u),(pppSexp ((ppp t) : (map ppp l)))]) 91 | ppp (Set4 u t) = (pppSexp [text "set!",(ppp u),(pppSexp [text "alloc",(ppp t)])]) 92 | ppp (Set5 u t t2) = (pppSexp [text "set!",(ppp u),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 93 | instance PP Triv where 94 | pp (UVar u) = (pp u) 95 | pp (Integer i) = (pp i) 96 | pp (Label l) = (pp l) 97 | ppp (UVar u) = (ppp u) 98 | ppp (Integer i) = (ppp i) 99 | ppp (Label l) = (ppp l) 100 | instance PP Prog where 101 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,l2,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp (map pp l2)),(pp b)])])) l)),(pp b)]) 102 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,l2,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp (map ppp l2)),(ppp b)])])) l)),(ppp b)]) 103 | instance PP Body where 104 | pp (Locals l t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(pp t)]) 105 | ppp (Locals l t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(ppp t)]) 106 | 107 | deriving instance Eq Tail 108 | deriving instance Read Tail 109 | deriving instance Show Tail 110 | deriving instance Ord Tail 111 | deriving instance Eq Pred 112 | deriving instance Read Pred 113 | deriving instance Show Pred 114 | deriving instance Ord Pred 115 | deriving instance Eq Effect 116 | deriving instance Read Effect 117 | deriving instance Show Effect 118 | deriving instance Ord Effect 119 | deriving instance Eq Triv 120 | deriving instance Read Triv 121 | deriving instance Show Triv 122 | deriving instance Ord Triv 123 | deriving instance Eq Prog 124 | deriving instance Read Prog 125 | deriving instance Show Prog 126 | deriving instance Ord Prog 127 | deriving instance Eq Body 128 | deriving instance Read Body 129 | deriving instance Show Body 130 | deriving instance Ord Body 131 | 132 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L25ImposeCallingConventions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L25ImposeCallingConventions where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv [Var] 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | Set1 Var Triv 28 | | Set2 Var Binop Triv Triv 29 | | Set3 Var Triv 30 | | Set4 Var Triv Triv 31 | | ReturnPoint Label Tail 32 | data Triv 33 | = Integer Integer 34 | | Label Label 35 | | Var Var 36 | data Prog 37 | = Letrec [(Label,Body)] Body 38 | data Body 39 | = Locals [UVar] [Frame] Tail 40 | data Loc 41 | = Reg Reg 42 | | FVar FVar 43 | data Var 44 | = UVar UVar 45 | | Loc Loc 46 | data Frame 47 | = AppF [UVar] 48 | 49 | instance PP Tail where 50 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 51 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 52 | pp (AppT t l) = (ppSexp ((pp t) : (map pp l))) 53 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 54 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 55 | ppp (AppT t l) = (pppSexp ((ppp t) : (map ppp l))) 56 | instance PP Pred where 57 | pp (TrueP) = (ppSexp [fromByteString "true"]) 58 | pp (FalseP) = (ppSexp [fromByteString "false"]) 59 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 60 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 61 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 62 | ppp (TrueP) = (pppSexp [text "true"]) 63 | ppp (FalseP) = (pppSexp [text "false"]) 64 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 65 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 66 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 67 | instance PP Effect where 68 | pp (Nop) = (ppSexp [fromByteString "nop"]) 69 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 70 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 71 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 72 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 73 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 74 | pp (Set3 v t) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "alloc",(pp t)])]) 75 | pp (Set4 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 76 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 77 | ppp (Nop) = (pppSexp [text "nop"]) 78 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 79 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 80 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 81 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 82 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 83 | ppp (Set3 v t) = (pppSexp [text "set!",(ppp v),(pppSexp [text "alloc",(ppp t)])]) 84 | ppp (Set4 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 85 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 86 | instance PP Triv where 87 | pp (Integer i) = (pp i) 88 | pp (Label l) = (pp l) 89 | pp (Var v) = (pp v) 90 | ppp (Integer i) = (ppp i) 91 | ppp (Label l) = (ppp l) 92 | ppp (Var v) = (ppp v) 93 | instance PP Prog where 94 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 95 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 96 | instance PP Body where 97 | pp (Locals l l2 t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(ppSexp [fromByteString "new-frames",(ppSexp (map pp l2)),(pp t)])]) 98 | ppp (Locals l l2 t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(pppSexp [text "new-frames",(pppSexp (map ppp l2)),(ppp t)])]) 99 | instance PP Loc where 100 | pp (Reg r) = (pp r) 101 | pp (FVar f) = (pp f) 102 | ppp (Reg r) = (ppp r) 103 | ppp (FVar f) = (ppp f) 104 | instance PP Var where 105 | pp (UVar u) = (pp u) 106 | pp (Loc l) = (pp l) 107 | ppp (UVar u) = (ppp u) 108 | ppp (Loc l) = (ppp l) 109 | instance PP Frame where 110 | pp (AppF l) = (ppSexp (map pp l)) 111 | ppp (AppF l) = (pppSexp (map ppp l)) 112 | 113 | deriving instance Eq Tail 114 | deriving instance Read Tail 115 | deriving instance Show Tail 116 | deriving instance Ord Tail 117 | deriving instance Eq Pred 118 | deriving instance Read Pred 119 | deriving instance Show Pred 120 | deriving instance Ord Pred 121 | deriving instance Eq Effect 122 | deriving instance Read Effect 123 | deriving instance Show Effect 124 | deriving instance Ord Effect 125 | deriving instance Eq Triv 126 | deriving instance Read Triv 127 | deriving instance Show Triv 128 | deriving instance Ord Triv 129 | deriving instance Eq Prog 130 | deriving instance Read Prog 131 | deriving instance Show Prog 132 | deriving instance Ord Prog 133 | deriving instance Eq Body 134 | deriving instance Read Body 135 | deriving instance Show Body 136 | deriving instance Ord Body 137 | deriving instance Eq Loc 138 | deriving instance Read Loc 139 | deriving instance Show Loc 140 | deriving instance Ord Loc 141 | deriving instance Eq Var 142 | deriving instance Read Var 143 | deriving instance Show Var 144 | deriving instance Ord Var 145 | deriving instance Eq Frame 146 | deriving instance Read Frame 147 | deriving instance Show Frame 148 | deriving instance Ord Frame 149 | 150 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L26ExposeAllocationPointer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L26ExposeAllocationPointer where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv [Var] 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Var Triv 29 | | Set2 Var Binop Triv Triv 30 | | Set3 Var Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Var Var 35 | data Prog 36 | = Letrec [(Label,Body)] Body 37 | data Body 38 | = Locals [UVar] [Frame] Tail 39 | data Loc 40 | = Reg Reg 41 | | FVar FVar 42 | data Var 43 | = UVar UVar 44 | | Loc Loc 45 | data Frame 46 | = AppF [UVar] 47 | 48 | instance PP Tail where 49 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 50 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 51 | pp (AppT t l) = (ppSexp ((pp t) : (map pp l))) 52 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 53 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 54 | ppp (AppT t l) = (pppSexp ((ppp t) : (map ppp l))) 55 | instance PP Pred where 56 | pp (TrueP) = (ppSexp [fromByteString "true"]) 57 | pp (FalseP) = (ppSexp [fromByteString "false"]) 58 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 59 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 60 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 61 | ppp (TrueP) = (pppSexp [text "true"]) 62 | ppp (FalseP) = (pppSexp [text "false"]) 63 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 64 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 65 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 66 | instance PP Effect where 67 | pp (Nop) = (ppSexp [fromByteString "nop"]) 68 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 69 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 70 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 71 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 72 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 73 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 74 | pp (Set3 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 75 | ppp (Nop) = (pppSexp [text "nop"]) 76 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 77 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 78 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 79 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 80 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 81 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 82 | ppp (Set3 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 83 | instance PP Triv where 84 | pp (Integer i) = (pp i) 85 | pp (Label l) = (pp l) 86 | pp (Var v) = (pp v) 87 | ppp (Integer i) = (ppp i) 88 | ppp (Label l) = (ppp l) 89 | ppp (Var v) = (ppp v) 90 | instance PP Prog where 91 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 92 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 93 | instance PP Body where 94 | pp (Locals l l2 t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(ppSexp [fromByteString "new-frames",(ppSexp (map pp l2)),(pp t)])]) 95 | ppp (Locals l l2 t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(pppSexp [text "new-frames",(pppSexp (map ppp l2)),(ppp t)])]) 96 | instance PP Loc where 97 | pp (Reg r) = (pp r) 98 | pp (FVar f) = (pp f) 99 | ppp (Reg r) = (ppp r) 100 | ppp (FVar f) = (ppp f) 101 | instance PP Var where 102 | pp (UVar u) = (pp u) 103 | pp (Loc l) = (pp l) 104 | ppp (UVar u) = (ppp u) 105 | ppp (Loc l) = (ppp l) 106 | instance PP Frame where 107 | pp (AppF l) = (ppSexp (map pp l)) 108 | ppp (AppF l) = (pppSexp (map ppp l)) 109 | 110 | deriving instance Eq Tail 111 | deriving instance Read Tail 112 | deriving instance Show Tail 113 | deriving instance Ord Tail 114 | deriving instance Eq Pred 115 | deriving instance Read Pred 116 | deriving instance Show Pred 117 | deriving instance Ord Pred 118 | deriving instance Eq Effect 119 | deriving instance Read Effect 120 | deriving instance Show Effect 121 | deriving instance Ord Effect 122 | deriving instance Eq Triv 123 | deriving instance Read Triv 124 | deriving instance Show Triv 125 | deriving instance Ord Triv 126 | deriving instance Eq Prog 127 | deriving instance Read Prog 128 | deriving instance Show Prog 129 | deriving instance Ord Prog 130 | deriving instance Eq Body 131 | deriving instance Read Body 132 | deriving instance Show Body 133 | deriving instance Ord Body 134 | deriving instance Eq Loc 135 | deriving instance Read Loc 136 | deriving instance Show Loc 137 | deriving instance Ord Loc 138 | deriving instance Eq Var 139 | deriving instance Read Var 140 | deriving instance Show Var 141 | deriving instance Ord Var 142 | deriving instance Eq Frame 143 | deriving instance Read Frame 144 | deriving instance Show Frame 145 | deriving instance Ord Frame 146 | 147 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L27UncoverFrameConflict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L27UncoverFrameConflict where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv [Var] 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Var Triv 29 | | Set2 Var Binop Triv Triv 30 | | Set3 Var Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Var Var 35 | data Prog 36 | = Letrec [(Label,Body)] Body 37 | data Loc 38 | = Reg Reg 39 | | FVarL FVar 40 | data Var 41 | = UVarV UVar 42 | | Loc Loc 43 | data Frame 44 | = AppF [UVar] 45 | data Body 46 | = Locals [UVar] [Frame] [UVar] [(UVar,[Var])] [UFVar] Tail 47 | data UFVar 48 | = UVarU UVar 49 | | FVarU FVar 50 | 51 | instance PP Tail where 52 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 53 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 54 | pp (AppT t l) = (ppSexp ((pp t) : (map pp l))) 55 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 56 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 57 | ppp (AppT t l) = (pppSexp ((ppp t) : (map ppp l))) 58 | instance PP Pred where 59 | pp (TrueP) = (ppSexp [fromByteString "true"]) 60 | pp (FalseP) = (ppSexp [fromByteString "false"]) 61 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 62 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 63 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 64 | ppp (TrueP) = (pppSexp [text "true"]) 65 | ppp (FalseP) = (pppSexp [text "false"]) 66 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 67 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 68 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 69 | instance PP Effect where 70 | pp (Nop) = (ppSexp [fromByteString "nop"]) 71 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 72 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 73 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 74 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 75 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 76 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 77 | pp (Set3 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 78 | ppp (Nop) = (pppSexp [text "nop"]) 79 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 80 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 81 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 82 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 83 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 84 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 85 | ppp (Set3 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 86 | instance PP Triv where 87 | pp (Integer i) = (pp i) 88 | pp (Label l) = (pp l) 89 | pp (Var v) = (pp v) 90 | ppp (Integer i) = (ppp i) 91 | ppp (Label l) = (ppp l) 92 | ppp (Var v) = (ppp v) 93 | instance PP Prog where 94 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 95 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 96 | instance PP Loc where 97 | pp (Reg r) = (pp r) 98 | pp (FVarL f) = (pp f) 99 | ppp (Reg r) = (ppp r) 100 | ppp (FVarL f) = (ppp f) 101 | instance PP Var where 102 | pp (UVarV u) = (pp u) 103 | pp (Loc l) = (pp l) 104 | ppp (UVarV u) = (ppp u) 105 | ppp (Loc l) = (ppp l) 106 | instance PP Frame where 107 | pp (AppF l) = (ppSexp (map pp l)) 108 | ppp (AppF l) = (pppSexp (map ppp l)) 109 | instance PP Body where 110 | pp (Locals l l2 l3 l4 l5 t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(ppSexp [fromByteString "new-frames",(ppSexp (map pp l2)),(ppSexp [fromByteString "spills",(ppSexp (map pp l3)),(ppSexp [fromByteString "frame-conflict",(ppSexp (map (\(u,l) -> (ppSexp ((pp u) : (map pp l)))) l4)),(ppSexp [fromByteString "call-live",(ppSexp (map pp l5)),(pp t)])])])])]) 111 | ppp (Locals l l2 l3 l4 l5 t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(pppSexp [text "new-frames",(pppSexp (map ppp l2)),(pppSexp [text "spills",(pppSexp (map ppp l3)),(pppSexp [text "frame-conflict",(pppSexp (map (\(u,l) -> (pppSexp ((ppp u) : (map ppp l)))) l4)),(pppSexp [text "call-live",(pppSexp (map ppp l5)),(ppp t)])])])])]) 112 | instance PP UFVar where 113 | pp (UVarU u) = (pp u) 114 | pp (FVarU f) = (pp f) 115 | ppp (UVarU u) = (ppp u) 116 | ppp (FVarU f) = (ppp f) 117 | 118 | deriving instance Eq Tail 119 | deriving instance Read Tail 120 | deriving instance Show Tail 121 | deriving instance Ord Tail 122 | deriving instance Eq Pred 123 | deriving instance Read Pred 124 | deriving instance Show Pred 125 | deriving instance Ord Pred 126 | deriving instance Eq Effect 127 | deriving instance Read Effect 128 | deriving instance Show Effect 129 | deriving instance Ord Effect 130 | deriving instance Eq Triv 131 | deriving instance Read Triv 132 | deriving instance Show Triv 133 | deriving instance Ord Triv 134 | deriving instance Eq Prog 135 | deriving instance Read Prog 136 | deriving instance Show Prog 137 | deriving instance Ord Prog 138 | deriving instance Eq Loc 139 | deriving instance Read Loc 140 | deriving instance Show Loc 141 | deriving instance Ord Loc 142 | deriving instance Eq Var 143 | deriving instance Read Var 144 | deriving instance Show Var 145 | deriving instance Ord Var 146 | deriving instance Eq Frame 147 | deriving instance Read Frame 148 | deriving instance Show Frame 149 | deriving instance Ord Frame 150 | deriving instance Eq Body 151 | deriving instance Read Body 152 | deriving instance Show Body 153 | deriving instance Ord Body 154 | deriving instance Eq UFVar 155 | deriving instance Read UFVar 156 | deriving instance Show UFVar 157 | deriving instance Ord UFVar 158 | 159 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L28PreAssignFrame.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L28PreAssignFrame where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv [Var] 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Var Triv 29 | | Set2 Var Binop Triv Triv 30 | | Set3 Var Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Var Var 35 | data Prog 36 | = Letrec [(Label,Body)] Body 37 | data Loc 38 | = Reg Reg 39 | | FVarL FVar 40 | data Var 41 | = UVarV UVar 42 | | Loc Loc 43 | data Frame 44 | = AppF [UVar] 45 | data UFVar 46 | = UVarU UVar 47 | | FVarU FVar 48 | data Body 49 | = Locals [UVar] [Frame] [(UVar,FVar)] [(UVar,[Var])] [UFVar] Tail 50 | 51 | instance PP Tail where 52 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 53 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 54 | pp (AppT t l) = (ppSexp ((pp t) : (map pp l))) 55 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 56 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 57 | ppp (AppT t l) = (pppSexp ((ppp t) : (map ppp l))) 58 | instance PP Pred where 59 | pp (TrueP) = (ppSexp [fromByteString "true"]) 60 | pp (FalseP) = (ppSexp [fromByteString "false"]) 61 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 62 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 63 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 64 | ppp (TrueP) = (pppSexp [text "true"]) 65 | ppp (FalseP) = (pppSexp [text "false"]) 66 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 67 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 68 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 69 | instance PP Effect where 70 | pp (Nop) = (ppSexp [fromByteString "nop"]) 71 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 72 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 73 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 74 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 75 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 76 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 77 | pp (Set3 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 78 | ppp (Nop) = (pppSexp [text "nop"]) 79 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 80 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 81 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 82 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 83 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 84 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 85 | ppp (Set3 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 86 | instance PP Triv where 87 | pp (Integer i) = (pp i) 88 | pp (Label l) = (pp l) 89 | pp (Var v) = (pp v) 90 | ppp (Integer i) = (ppp i) 91 | ppp (Label l) = (ppp l) 92 | ppp (Var v) = (ppp v) 93 | instance PP Prog where 94 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 95 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 96 | instance PP Loc where 97 | pp (Reg r) = (pp r) 98 | pp (FVarL f) = (pp f) 99 | ppp (Reg r) = (ppp r) 100 | ppp (FVarL f) = (ppp f) 101 | instance PP Var where 102 | pp (UVarV u) = (pp u) 103 | pp (Loc l) = (pp l) 104 | ppp (UVarV u) = (ppp u) 105 | ppp (Loc l) = (ppp l) 106 | instance PP Frame where 107 | pp (AppF l) = (ppSexp (map pp l)) 108 | ppp (AppF l) = (pppSexp (map ppp l)) 109 | instance PP UFVar where 110 | pp (UVarU u) = (pp u) 111 | pp (FVarU f) = (pp f) 112 | ppp (UVarU u) = (ppp u) 113 | ppp (FVarU f) = (ppp f) 114 | instance PP Body where 115 | pp (Locals l l2 l3 l4 l5 t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(ppSexp [fromByteString "new-frames",(ppSexp (map pp l2)),(ppSexp [fromByteString "locate",(ppSexp (map (\(u,f) -> (ppSexp [(pp u),(pp f)])) l3)),(ppSexp [fromByteString "frame-conflict",(ppSexp (map (\(u,l) -> (ppSexp ((pp u) : (map pp l)))) l4)),(ppSexp [fromByteString "call-live",(ppSexp (map pp l5)),(pp t)])])])])]) 116 | ppp (Locals l l2 l3 l4 l5 t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(pppSexp [text "new-frames",(pppSexp (map ppp l2)),(pppSexp [text "locate",(pppSexp (map (\(u,f) -> (pppSexp [(ppp u),(ppp f)])) l3)),(pppSexp [text "frame-conflict",(pppSexp (map (\(u,l) -> (pppSexp ((ppp u) : (map ppp l)))) l4)),(pppSexp [text "call-live",(pppSexp (map ppp l5)),(ppp t)])])])])]) 117 | 118 | deriving instance Eq Tail 119 | deriving instance Read Tail 120 | deriving instance Show Tail 121 | deriving instance Ord Tail 122 | deriving instance Eq Pred 123 | deriving instance Read Pred 124 | deriving instance Show Pred 125 | deriving instance Ord Pred 126 | deriving instance Eq Effect 127 | deriving instance Read Effect 128 | deriving instance Show Effect 129 | deriving instance Ord Effect 130 | deriving instance Eq Triv 131 | deriving instance Read Triv 132 | deriving instance Show Triv 133 | deriving instance Ord Triv 134 | deriving instance Eq Prog 135 | deriving instance Read Prog 136 | deriving instance Show Prog 137 | deriving instance Ord Prog 138 | deriving instance Eq Loc 139 | deriving instance Read Loc 140 | deriving instance Show Loc 141 | deriving instance Ord Loc 142 | deriving instance Eq Var 143 | deriving instance Read Var 144 | deriving instance Show Var 145 | deriving instance Ord Var 146 | deriving instance Eq Frame 147 | deriving instance Read Frame 148 | deriving instance Show Frame 149 | deriving instance Ord Frame 150 | deriving instance Eq UFVar 151 | deriving instance Read UFVar 152 | deriving instance Show UFVar 153 | deriving instance Ord UFVar 154 | deriving instance Eq Body 155 | deriving instance Read Body 156 | deriving instance Show Body 157 | deriving instance Ord Body 158 | 159 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L29AssignNewFrame.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L29AssignNewFrame where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv [Var] 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Var Triv 29 | | Set2 Var Binop Triv Triv 30 | | Set3 Var Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Var Var 35 | data Prog 36 | = Letrec [(Label,Body)] Body 37 | data Loc 38 | = Reg Reg 39 | | FVar FVar 40 | data Var 41 | = UVar UVar 42 | | Loc Loc 43 | data Body 44 | = Locals [UVar] [UVar] [(UVar,FVar)] [(UVar,[Var])] Tail 45 | | Locate [(UVar,Loc)] Tail 46 | 47 | instance PP Tail where 48 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 49 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 50 | pp (AppT t l) = (ppSexp ((pp t) : (map pp l))) 51 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 52 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 53 | ppp (AppT t l) = (pppSexp ((ppp t) : (map ppp l))) 54 | instance PP Pred where 55 | pp (TrueP) = (ppSexp [fromByteString "true"]) 56 | pp (FalseP) = (ppSexp [fromByteString "false"]) 57 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 58 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 59 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 60 | ppp (TrueP) = (pppSexp [text "true"]) 61 | ppp (FalseP) = (pppSexp [text "false"]) 62 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 63 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 64 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 65 | instance PP Effect where 66 | pp (Nop) = (ppSexp [fromByteString "nop"]) 67 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 68 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 69 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 70 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 71 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 72 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 73 | pp (Set3 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 74 | ppp (Nop) = (pppSexp [text "nop"]) 75 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 76 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 77 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 78 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 79 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 80 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 81 | ppp (Set3 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 82 | instance PP Triv where 83 | pp (Integer i) = (pp i) 84 | pp (Label l) = (pp l) 85 | pp (Var v) = (pp v) 86 | ppp (Integer i) = (ppp i) 87 | ppp (Label l) = (ppp l) 88 | ppp (Var v) = (ppp v) 89 | instance PP Prog where 90 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 91 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 92 | instance PP Loc where 93 | pp (Reg r) = (pp r) 94 | pp (FVar f) = (pp f) 95 | ppp (Reg r) = (ppp r) 96 | ppp (FVar f) = (ppp f) 97 | instance PP Var where 98 | pp (UVar u) = (pp u) 99 | pp (Loc l) = (pp l) 100 | ppp (UVar u) = (ppp u) 101 | ppp (Loc l) = (ppp l) 102 | instance PP Body where 103 | pp (Locals l l2 l3 l4 t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(ppSexp [fromByteString "ulocals",(ppSexp (map pp l2)),(ppSexp [fromByteString "locate",(ppSexp (map (\(u,f) -> (ppSexp [(pp u),(pp f)])) l3)),(ppSexp [fromByteString "frame-conflict",(ppSexp (map (\(u,l) -> (ppSexp ((pp u) : (map pp l)))) l4)),(pp t)])])])]) 104 | pp (Locate l t) = (ppSexp [fromByteString "locate",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp t)]) 105 | ppp (Locals l l2 l3 l4 t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(pppSexp [text "ulocals",(pppSexp (map ppp l2)),(pppSexp [text "locate",(pppSexp (map (\(u,f) -> (pppSexp [(ppp u),(ppp f)])) l3)),(pppSexp [text "frame-conflict",(pppSexp (map (\(u,l) -> (pppSexp ((ppp u) : (map ppp l)))) l4)),(ppp t)])])])]) 106 | ppp (Locate l t) = (pppSexp [text "locate",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp t)]) 107 | 108 | deriving instance Eq Tail 109 | deriving instance Read Tail 110 | deriving instance Show Tail 111 | deriving instance Ord Tail 112 | deriving instance Eq Pred 113 | deriving instance Read Pred 114 | deriving instance Show Pred 115 | deriving instance Ord Pred 116 | deriving instance Eq Effect 117 | deriving instance Read Effect 118 | deriving instance Show Effect 119 | deriving instance Ord Effect 120 | deriving instance Eq Triv 121 | deriving instance Read Triv 122 | deriving instance Show Triv 123 | deriving instance Ord Triv 124 | deriving instance Eq Prog 125 | deriving instance Read Prog 126 | deriving instance Show Prog 127 | deriving instance Ord Prog 128 | deriving instance Eq Loc 129 | deriving instance Read Loc 130 | deriving instance Show Loc 131 | deriving instance Ord Loc 132 | deriving instance Eq Var 133 | deriving instance Read Var 134 | deriving instance Show Var 135 | deriving instance Ord Var 136 | deriving instance Eq Body 137 | deriving instance Read Body 138 | deriving instance Show Body 139 | deriving instance Ord Body 140 | 141 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L30FinalizeFrameLocations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L30FinalizeFrameLocations where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv [Loc] 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Var Triv 29 | | Set2 Var Binop Triv Triv 30 | | Set3 Var Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Var Var 35 | data Prog 36 | = Letrec [(Label,Body)] Body 37 | data Loc 38 | = Reg Reg 39 | | FVar FVar 40 | data Var 41 | = UVar UVar 42 | | Loc Loc 43 | data Body 44 | = Locals [UVar] [UVar] [(UVar,FVar)] [(UVar,[Var])] Tail 45 | | Locate [(UVar,Loc)] Tail 46 | 47 | instance PP Tail where 48 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 49 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 50 | pp (AppT t l) = (ppSexp ((pp t) : (map pp l))) 51 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 52 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 53 | ppp (AppT t l) = (pppSexp ((ppp t) : (map ppp l))) 54 | instance PP Pred where 55 | pp (TrueP) = (ppSexp [fromByteString "true"]) 56 | pp (FalseP) = (ppSexp [fromByteString "false"]) 57 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 58 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 59 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 60 | ppp (TrueP) = (pppSexp [text "true"]) 61 | ppp (FalseP) = (pppSexp [text "false"]) 62 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 63 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 64 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 65 | instance PP Effect where 66 | pp (Nop) = (ppSexp [fromByteString "nop"]) 67 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 68 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 69 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 70 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 71 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 72 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 73 | pp (Set3 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 74 | ppp (Nop) = (pppSexp [text "nop"]) 75 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 76 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 77 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 78 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 79 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 80 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 81 | ppp (Set3 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 82 | instance PP Triv where 83 | pp (Integer i) = (pp i) 84 | pp (Label l) = (pp l) 85 | pp (Var v) = (pp v) 86 | ppp (Integer i) = (ppp i) 87 | ppp (Label l) = (ppp l) 88 | ppp (Var v) = (ppp v) 89 | instance PP Prog where 90 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 91 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 92 | instance PP Loc where 93 | pp (Reg r) = (pp r) 94 | pp (FVar f) = (pp f) 95 | ppp (Reg r) = (ppp r) 96 | ppp (FVar f) = (ppp f) 97 | instance PP Var where 98 | pp (UVar u) = (pp u) 99 | pp (Loc l) = (pp l) 100 | ppp (UVar u) = (ppp u) 101 | ppp (Loc l) = (ppp l) 102 | instance PP Body where 103 | pp (Locals l l2 l3 l4 t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(ppSexp [fromByteString "ulocals",(ppSexp (map pp l2)),(ppSexp [fromByteString "locate",(ppSexp (map (\(u,f) -> (ppSexp [(pp u),(pp f)])) l3)),(ppSexp [fromByteString "frame-conflict",(ppSexp (map (\(u,l) -> (ppSexp ((pp u) : (map pp l)))) l4)),(pp t)])])])]) 104 | pp (Locate l t) = (ppSexp [fromByteString "locate",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp t)]) 105 | ppp (Locals l l2 l3 l4 t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(pppSexp [text "ulocals",(pppSexp (map ppp l2)),(pppSexp [text "locate",(pppSexp (map (\(u,f) -> (pppSexp [(ppp u),(ppp f)])) l3)),(pppSexp [text "frame-conflict",(pppSexp (map (\(u,l) -> (pppSexp ((ppp u) : (map ppp l)))) l4)),(ppp t)])])])]) 106 | ppp (Locate l t) = (pppSexp [text "locate",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp t)]) 107 | 108 | deriving instance Eq Tail 109 | deriving instance Read Tail 110 | deriving instance Show Tail 111 | deriving instance Ord Tail 112 | deriving instance Eq Pred 113 | deriving instance Read Pred 114 | deriving instance Show Pred 115 | deriving instance Ord Pred 116 | deriving instance Eq Effect 117 | deriving instance Read Effect 118 | deriving instance Show Effect 119 | deriving instance Ord Effect 120 | deriving instance Eq Triv 121 | deriving instance Read Triv 122 | deriving instance Show Triv 123 | deriving instance Ord Triv 124 | deriving instance Eq Prog 125 | deriving instance Read Prog 126 | deriving instance Show Prog 127 | deriving instance Ord Prog 128 | deriving instance Eq Loc 129 | deriving instance Read Loc 130 | deriving instance Show Loc 131 | deriving instance Ord Loc 132 | deriving instance Eq Var 133 | deriving instance Read Var 134 | deriving instance Show Var 135 | deriving instance Ord Var 136 | deriving instance Eq Body 137 | deriving instance Read Body 138 | deriving instance Show Body 139 | deriving instance Ord Body 140 | 141 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L32UncoverRegisterConflict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L32UncoverRegisterConflict where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv [Loc] 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Var Triv 29 | | Set2 Var Binop Triv Triv 30 | | Set3 Var Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Var Var 35 | data Prog 36 | = Letrec [(Label,Body)] Body 37 | data Loc 38 | = RegL Reg 39 | | FVar FVar 40 | data Var 41 | = UVarV UVar 42 | | Loc Loc 43 | data Body 44 | = Locate [(UVar,Loc)] Tail 45 | | Locals [UVar] [UVar] [(UVar,FVar)] [(UVar,[Var])] [(UVar,[Conflict])] Tail 46 | data Conflict 47 | = RegC Reg 48 | | UVarC UVar 49 | 50 | instance PP Tail where 51 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 52 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 53 | pp (AppT t l) = (ppSexp ((pp t) : (map pp l))) 54 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 55 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 56 | ppp (AppT t l) = (pppSexp ((ppp t) : (map ppp l))) 57 | instance PP Pred where 58 | pp (TrueP) = (ppSexp [fromByteString "true"]) 59 | pp (FalseP) = (ppSexp [fromByteString "false"]) 60 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 61 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 62 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 63 | ppp (TrueP) = (pppSexp [text "true"]) 64 | ppp (FalseP) = (pppSexp [text "false"]) 65 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 66 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 67 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 68 | instance PP Effect where 69 | pp (Nop) = (ppSexp [fromByteString "nop"]) 70 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 71 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 72 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 73 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 74 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 75 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 76 | pp (Set3 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 77 | ppp (Nop) = (pppSexp [text "nop"]) 78 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 79 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 80 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 81 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 82 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 83 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 84 | ppp (Set3 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 85 | instance PP Triv where 86 | pp (Integer i) = (pp i) 87 | pp (Label l) = (pp l) 88 | pp (Var v) = (pp v) 89 | ppp (Integer i) = (ppp i) 90 | ppp (Label l) = (ppp l) 91 | ppp (Var v) = (ppp v) 92 | instance PP Prog where 93 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 94 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 95 | instance PP Loc where 96 | pp (RegL r) = (pp r) 97 | pp (FVar f) = (pp f) 98 | ppp (RegL r) = (ppp r) 99 | ppp (FVar f) = (ppp f) 100 | instance PP Var where 101 | pp (UVarV u) = (pp u) 102 | pp (Loc l) = (pp l) 103 | ppp (UVarV u) = (ppp u) 104 | ppp (Loc l) = (ppp l) 105 | instance PP Body where 106 | pp (Locate l t) = (ppSexp [fromByteString "locate",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp t)]) 107 | pp (Locals l l2 l3 l4 l5 t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(ppSexp [fromByteString "ulocals",(ppSexp (map pp l2)),(ppSexp [fromByteString "locate",(ppSexp (map (\(u,f) -> (ppSexp [(pp u),(pp f)])) l3)),(ppSexp [fromByteString "frame-conflict",(ppSexp (map (\(u,l) -> (ppSexp ((pp u) : (map pp l)))) l4)),(ppSexp [fromByteString "register-conflict",(ppSexp (map (\(u,l) -> (ppSexp ((pp u) : (map pp l)))) l5)),(pp t)])])])])]) 108 | ppp (Locate l t) = (pppSexp [text "locate",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp t)]) 109 | ppp (Locals l l2 l3 l4 l5 t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(pppSexp [text "ulocals",(pppSexp (map ppp l2)),(pppSexp [text "locate",(pppSexp (map (\(u,f) -> (pppSexp [(ppp u),(ppp f)])) l3)),(pppSexp [text "frame-conflict",(pppSexp (map (\(u,l) -> (pppSexp ((ppp u) : (map ppp l)))) l4)),(pppSexp [text "register-conflict",(pppSexp (map (\(u,l) -> (pppSexp ((ppp u) : (map ppp l)))) l5)),(ppp t)])])])])]) 110 | instance PP Conflict where 111 | pp (RegC r) = (pp r) 112 | pp (UVarC u) = (pp u) 113 | ppp (RegC r) = (ppp r) 114 | ppp (UVarC u) = (ppp u) 115 | 116 | deriving instance Eq Tail 117 | deriving instance Read Tail 118 | deriving instance Show Tail 119 | deriving instance Ord Tail 120 | deriving instance Eq Pred 121 | deriving instance Read Pred 122 | deriving instance Show Pred 123 | deriving instance Ord Pred 124 | deriving instance Eq Effect 125 | deriving instance Read Effect 126 | deriving instance Show Effect 127 | deriving instance Ord Effect 128 | deriving instance Eq Triv 129 | deriving instance Read Triv 130 | deriving instance Show Triv 131 | deriving instance Ord Triv 132 | deriving instance Eq Prog 133 | deriving instance Read Prog 134 | deriving instance Show Prog 135 | deriving instance Ord Prog 136 | deriving instance Eq Loc 137 | deriving instance Read Loc 138 | deriving instance Show Loc 139 | deriving instance Ord Loc 140 | deriving instance Eq Var 141 | deriving instance Read Var 142 | deriving instance Show Var 143 | deriving instance Ord Var 144 | deriving instance Eq Body 145 | deriving instance Read Body 146 | deriving instance Show Body 147 | deriving instance Ord Body 148 | deriving instance Eq Conflict 149 | deriving instance Read Conflict 150 | deriving instance Show Conflict 151 | deriving instance Ord Conflict 152 | 153 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L33AssignRegisters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L33AssignRegisters where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv [Loc] 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Var Triv 29 | | Set2 Var Binop Triv Triv 30 | | Set3 Var Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Var Var 35 | data Prog 36 | = Letrec [(Label,Body)] Body 37 | data Loc 38 | = Reg Reg 39 | | FVar FVar 40 | data Var 41 | = UVar UVar 42 | | Loc Loc 43 | data Body 44 | = Locate [(UVar,Loc)] Tail 45 | | Locals [UVar] [UVar] [UVar] [(UVar,FVar)] [(UVar,[Var])] Tail 46 | 47 | instance PP Tail where 48 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 49 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 50 | pp (AppT t l) = (ppSexp ((pp t) : (map pp l))) 51 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 52 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 53 | ppp (AppT t l) = (pppSexp ((ppp t) : (map ppp l))) 54 | instance PP Pred where 55 | pp (TrueP) = (ppSexp [fromByteString "true"]) 56 | pp (FalseP) = (ppSexp [fromByteString "false"]) 57 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 58 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 59 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 60 | ppp (TrueP) = (pppSexp [text "true"]) 61 | ppp (FalseP) = (pppSexp [text "false"]) 62 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 63 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 64 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 65 | instance PP Effect where 66 | pp (Nop) = (ppSexp [fromByteString "nop"]) 67 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 68 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 69 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 70 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 71 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 72 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 73 | pp (Set3 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 74 | ppp (Nop) = (pppSexp [text "nop"]) 75 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 76 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 77 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 78 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 79 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 80 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 81 | ppp (Set3 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 82 | instance PP Triv where 83 | pp (Integer i) = (pp i) 84 | pp (Label l) = (pp l) 85 | pp (Var v) = (pp v) 86 | ppp (Integer i) = (ppp i) 87 | ppp (Label l) = (ppp l) 88 | ppp (Var v) = (ppp v) 89 | instance PP Prog where 90 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 91 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 92 | instance PP Loc where 93 | pp (Reg r) = (pp r) 94 | pp (FVar f) = (pp f) 95 | ppp (Reg r) = (ppp r) 96 | ppp (FVar f) = (ppp f) 97 | instance PP Var where 98 | pp (UVar u) = (pp u) 99 | pp (Loc l) = (pp l) 100 | ppp (UVar u) = (ppp u) 101 | ppp (Loc l) = (ppp l) 102 | instance PP Body where 103 | pp (Locate l t) = (ppSexp [fromByteString "locate",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp t)]) 104 | pp (Locals l l2 l3 l4 l5 t) = (ppSexp [fromByteString "locals",(ppSexp (map pp l)),(ppSexp [fromByteString "ulocals",(ppSexp (map pp l2)),(ppSexp [fromByteString "spills",(ppSexp (map pp l3)),(ppSexp [fromByteString "locate",(ppSexp (map (\(u,f) -> (ppSexp [(pp u),(pp f)])) l4)),(ppSexp [fromByteString "frame-conflict",(ppSexp (map (\(u,l) -> (ppSexp ((pp u) : (map pp l)))) l5)),(pp t)])])])])]) 105 | ppp (Locate l t) = (pppSexp [text "locate",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp t)]) 106 | ppp (Locals l l2 l3 l4 l5 t) = (pppSexp [text "locals",(pppSexp (map ppp l)),(pppSexp [text "ulocals",(pppSexp (map ppp l2)),(pppSexp [text "spills",(pppSexp (map ppp l3)),(pppSexp [text "locate",(pppSexp (map (\(u,f) -> (pppSexp [(ppp u),(ppp f)])) l4)),(pppSexp [text "frame-conflict",(pppSexp (map (\(u,l) -> (pppSexp ((ppp u) : (map ppp l)))) l5)),(ppp t)])])])])]) 107 | 108 | deriving instance Eq Tail 109 | deriving instance Read Tail 110 | deriving instance Show Tail 111 | deriving instance Ord Tail 112 | deriving instance Eq Pred 113 | deriving instance Read Pred 114 | deriving instance Show Pred 115 | deriving instance Ord Pred 116 | deriving instance Eq Effect 117 | deriving instance Read Effect 118 | deriving instance Show Effect 119 | deriving instance Ord Effect 120 | deriving instance Eq Triv 121 | deriving instance Read Triv 122 | deriving instance Show Triv 123 | deriving instance Ord Triv 124 | deriving instance Eq Prog 125 | deriving instance Read Prog 126 | deriving instance Show Prog 127 | deriving instance Ord Prog 128 | deriving instance Eq Loc 129 | deriving instance Read Loc 130 | deriving instance Show Loc 131 | deriving instance Ord Loc 132 | deriving instance Eq Var 133 | deriving instance Read Var 134 | deriving instance Show Var 135 | deriving instance Ord Var 136 | deriving instance Eq Body 137 | deriving instance Read Body 138 | deriving instance Show Body 139 | deriving instance Ord Body 140 | 141 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L35DiscardCallLive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L35DiscardCallLive where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Var Triv 29 | | Set2 Var Binop Triv Triv 30 | | Set3 Var Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Var Var 35 | data Prog 36 | = Letrec [(Label,Body)] Body 37 | data Loc 38 | = Reg Reg 39 | | FVar FVar 40 | data Var 41 | = UVar UVar 42 | | Loc Loc 43 | data Body 44 | = Locate [(UVar,Loc)] Tail 45 | 46 | instance PP Tail where 47 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 48 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 49 | pp (AppT t) = (ppSexp [(pp t)]) 50 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 51 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 52 | ppp (AppT t) = (pppSexp [(ppp t)]) 53 | instance PP Pred where 54 | pp (TrueP) = (ppSexp [fromByteString "true"]) 55 | pp (FalseP) = (ppSexp [fromByteString "false"]) 56 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 57 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 58 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 59 | ppp (TrueP) = (pppSexp [text "true"]) 60 | ppp (FalseP) = (pppSexp [text "false"]) 61 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 62 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 63 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 64 | instance PP Effect where 65 | pp (Nop) = (ppSexp [fromByteString "nop"]) 66 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 67 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 68 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 69 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 70 | pp (Set1 v t) = (ppSexp [fromByteString "set!",(pp v),(pp t)]) 71 | pp (Set2 v b t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [(pp b),(pp t),(pp t2)])]) 72 | pp (Set3 v t t2) = (ppSexp [fromByteString "set!",(pp v),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 73 | ppp (Nop) = (pppSexp [text "nop"]) 74 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 75 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 76 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 77 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 78 | ppp (Set1 v t) = (pppSexp [text "set!",(ppp v),(ppp t)]) 79 | ppp (Set2 v b t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 80 | ppp (Set3 v t t2) = (pppSexp [text "set!",(ppp v),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 81 | instance PP Triv where 82 | pp (Integer i) = (pp i) 83 | pp (Label l) = (pp l) 84 | pp (Var v) = (pp v) 85 | ppp (Integer i) = (ppp i) 86 | ppp (Label l) = (ppp l) 87 | ppp (Var v) = (ppp v) 88 | instance PP Prog where 89 | pp (Letrec l b) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,b) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp b)])])) l)),(pp b)]) 90 | ppp (Letrec l b) = (pppSexp [text "letrec",(pppSexp (map (\(l,b) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp b)])])) l)),(ppp b)]) 91 | instance PP Loc where 92 | pp (Reg r) = (pp r) 93 | pp (FVar f) = (pp f) 94 | ppp (Reg r) = (ppp r) 95 | ppp (FVar f) = (ppp f) 96 | instance PP Var where 97 | pp (UVar u) = (pp u) 98 | pp (Loc l) = (pp l) 99 | ppp (UVar u) = (ppp u) 100 | ppp (Loc l) = (ppp l) 101 | instance PP Body where 102 | pp (Locate l t) = (ppSexp [fromByteString "locate",(ppSexp (map (\(u,l) -> (ppSexp [(pp u),(pp l)])) l)),(pp t)]) 103 | ppp (Locate l t) = (pppSexp [text "locate",(pppSexp (map (\(u,l) -> (pppSexp [(ppp u),(ppp l)])) l)),(ppp t)]) 104 | 105 | deriving instance Eq Tail 106 | deriving instance Read Tail 107 | deriving instance Show Tail 108 | deriving instance Ord Tail 109 | deriving instance Eq Pred 110 | deriving instance Read Pred 111 | deriving instance Show Pred 112 | deriving instance Ord Pred 113 | deriving instance Eq Effect 114 | deriving instance Read Effect 115 | deriving instance Show Effect 116 | deriving instance Ord Effect 117 | deriving instance Eq Triv 118 | deriving instance Read Triv 119 | deriving instance Show Triv 120 | deriving instance Ord Triv 121 | deriving instance Eq Prog 122 | deriving instance Read Prog 123 | deriving instance Show Prog 124 | deriving instance Ord Prog 125 | deriving instance Eq Loc 126 | deriving instance Read Loc 127 | deriving instance Show Loc 128 | deriving instance Ord Loc 129 | deriving instance Eq Var 130 | deriving instance Read Var 131 | deriving instance Show Var 132 | deriving instance Ord Var 133 | deriving instance Eq Body 134 | deriving instance Read Body 135 | deriving instance Show Body 136 | deriving instance Ord Body 137 | 138 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L36FinalizeLocations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L36FinalizeLocations where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Loc Triv 29 | | Set2 Loc Binop Triv Triv 30 | | Set3 Loc Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Loc Loc 35 | data Prog 36 | = Letrec [(Label,Tail)] Tail 37 | data Loc 38 | = Reg Reg 39 | | FVar FVar 40 | 41 | instance PP Tail where 42 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 43 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 44 | pp (AppT t) = (ppSexp [(pp t)]) 45 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 46 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 47 | ppp (AppT t) = (pppSexp [(ppp t)]) 48 | instance PP Pred where 49 | pp (TrueP) = (ppSexp [fromByteString "true"]) 50 | pp (FalseP) = (ppSexp [fromByteString "false"]) 51 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 52 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 53 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 54 | ppp (TrueP) = (pppSexp [text "true"]) 55 | ppp (FalseP) = (pppSexp [text "false"]) 56 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 57 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 58 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 59 | instance PP Effect where 60 | pp (Nop) = (ppSexp [fromByteString "nop"]) 61 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 62 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 63 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 64 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 65 | pp (Set1 l t) = (ppSexp [fromByteString "set!",(pp l),(pp t)]) 66 | pp (Set2 l b t t2) = (ppSexp [fromByteString "set!",(pp l),(ppSexp [(pp b),(pp t),(pp t2)])]) 67 | pp (Set3 l t t2) = (ppSexp [fromByteString "set!",(pp l),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 68 | ppp (Nop) = (pppSexp [text "nop"]) 69 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 70 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 71 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 72 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 73 | ppp (Set1 l t) = (pppSexp [text "set!",(ppp l),(ppp t)]) 74 | ppp (Set2 l b t t2) = (pppSexp [text "set!",(ppp l),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 75 | ppp (Set3 l t t2) = (pppSexp [text "set!",(ppp l),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 76 | instance PP Triv where 77 | pp (Integer i) = (pp i) 78 | pp (Label l) = (pp l) 79 | pp (Loc l) = (pp l) 80 | ppp (Integer i) = (ppp i) 81 | ppp (Label l) = (ppp l) 82 | ppp (Loc l) = (ppp l) 83 | instance PP Prog where 84 | pp (Letrec l t) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,t) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp t)])])) l)),(pp t)]) 85 | ppp (Letrec l t) = (pppSexp [text "letrec",(pppSexp (map (\(l,t) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp t)])])) l)),(ppp t)]) 86 | instance PP Loc where 87 | pp (Reg r) = (pp r) 88 | pp (FVar f) = (pp f) 89 | ppp (Reg r) = (ppp r) 90 | ppp (FVar f) = (ppp f) 91 | 92 | deriving instance Eq Tail 93 | deriving instance Read Tail 94 | deriving instance Show Tail 95 | deriving instance Ord Tail 96 | deriving instance Eq Pred 97 | deriving instance Read Pred 98 | deriving instance Show Pred 99 | deriving instance Ord Pred 100 | deriving instance Eq Effect 101 | deriving instance Read Effect 102 | deriving instance Show Effect 103 | deriving instance Ord Effect 104 | deriving instance Eq Triv 105 | deriving instance Read Triv 106 | deriving instance Show Triv 107 | deriving instance Ord Triv 108 | deriving instance Eq Prog 109 | deriving instance Read Prog 110 | deriving instance Show Prog 111 | deriving instance Ord Prog 112 | deriving instance Eq Loc 113 | deriving instance Read Loc 114 | deriving instance Show Loc 115 | deriving instance Ord Loc 116 | 117 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L37ExposeFrameVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L37ExposeFrameVar where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | Mset Triv Triv Triv 27 | | ReturnPoint Label Tail 28 | | Set1 Loc Triv 29 | | Set2 Loc Binop Triv Triv 30 | | Set3 Loc Triv Triv 31 | data Triv 32 | = Integer Integer 33 | | Label Label 34 | | Loc Loc 35 | data Prog 36 | = Letrec [(Label,Tail)] Tail 37 | data Loc 38 | = Reg Reg 39 | | Disp Disp 40 | 41 | instance PP Tail where 42 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 43 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 44 | pp (AppT t) = (ppSexp [(pp t)]) 45 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 46 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 47 | ppp (AppT t) = (pppSexp [(ppp t)]) 48 | instance PP Pred where 49 | pp (TrueP) = (ppSexp [fromByteString "true"]) 50 | pp (FalseP) = (ppSexp [fromByteString "false"]) 51 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 52 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 53 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 54 | ppp (TrueP) = (pppSexp [text "true"]) 55 | ppp (FalseP) = (pppSexp [text "false"]) 56 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 57 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 58 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 59 | instance PP Effect where 60 | pp (Nop) = (ppSexp [fromByteString "nop"]) 61 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 62 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 63 | pp (Mset t t2 t3) = (ppSexp [fromByteString "mset!",(pp t),(pp t2),(pp t3)]) 64 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 65 | pp (Set1 l t) = (ppSexp [fromByteString "set!",(pp l),(pp t)]) 66 | pp (Set2 l b t t2) = (ppSexp [fromByteString "set!",(pp l),(ppSexp [(pp b),(pp t),(pp t2)])]) 67 | pp (Set3 l t t2) = (ppSexp [fromByteString "set!",(pp l),(ppSexp [fromByteString "mref",(pp t),(pp t2)])]) 68 | ppp (Nop) = (pppSexp [text "nop"]) 69 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 70 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 71 | ppp (Mset t t2 t3) = (pppSexp [text "mset!",(ppp t),(ppp t2),(ppp t3)]) 72 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 73 | ppp (Set1 l t) = (pppSexp [text "set!",(ppp l),(ppp t)]) 74 | ppp (Set2 l b t t2) = (pppSexp [text "set!",(ppp l),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 75 | ppp (Set3 l t t2) = (pppSexp [text "set!",(ppp l),(pppSexp [text "mref",(ppp t),(ppp t2)])]) 76 | instance PP Triv where 77 | pp (Integer i) = (pp i) 78 | pp (Label l) = (pp l) 79 | pp (Loc l) = (pp l) 80 | ppp (Integer i) = (ppp i) 81 | ppp (Label l) = (ppp l) 82 | ppp (Loc l) = (ppp l) 83 | instance PP Prog where 84 | pp (Letrec l t) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,t) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp t)])])) l)),(pp t)]) 85 | ppp (Letrec l t) = (pppSexp [text "letrec",(pppSexp (map (\(l,t) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp t)])])) l)),(ppp t)]) 86 | instance PP Loc where 87 | pp (Reg r) = (pp r) 88 | pp (Disp d) = (pp d) 89 | ppp (Reg r) = (ppp r) 90 | ppp (Disp d) = (ppp d) 91 | 92 | deriving instance Eq Tail 93 | deriving instance Read Tail 94 | deriving instance Show Tail 95 | deriving instance Ord Tail 96 | deriving instance Eq Pred 97 | deriving instance Read Pred 98 | deriving instance Show Pred 99 | deriving instance Ord Pred 100 | deriving instance Eq Effect 101 | deriving instance Read Effect 102 | deriving instance Show Effect 103 | deriving instance Ord Effect 104 | deriving instance Eq Triv 105 | deriving instance Read Triv 106 | deriving instance Show Triv 107 | deriving instance Ord Triv 108 | deriving instance Eq Prog 109 | deriving instance Read Prog 110 | deriving instance Show Prog 111 | deriving instance Ord Prog 112 | deriving instance Eq Loc 113 | deriving instance Read Loc 114 | deriving instance Show Loc 115 | deriving instance Ord Loc 116 | 117 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L38ExposeMemoryOperands.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L38ExposeMemoryOperands where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = IfT Pred Tail Tail 14 | | BeginT [Effect] Tail 15 | | AppT Triv 16 | data Pred 17 | = TrueP 18 | | FalseP 19 | | IfP Pred Pred Pred 20 | | BeginP [Effect] Pred 21 | | AppP Relop Triv Triv 22 | data Effect 23 | = Nop 24 | | IfE Pred Effect Effect 25 | | BeginE [Effect] Effect 26 | | ReturnPoint Label Tail 27 | | Set1 Loc Triv 28 | | Set2 Loc Binop Triv Triv 29 | data Triv 30 | = Integer Integer 31 | | Label Label 32 | | Loc Loc 33 | data Prog 34 | = Letrec [(Label,Tail)] Tail 35 | data Loc 36 | = Reg Reg 37 | | Disp Disp 38 | | Ind Ind 39 | 40 | instance PP Tail where 41 | pp (IfT p t t2) = (ppSexp [fromByteString "if",(pp p),(pp t),(pp t2)]) 42 | pp (BeginT l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 43 | pp (AppT t) = (ppSexp [(pp t)]) 44 | ppp (IfT p t t2) = (pppSexp [text "if",(ppp p),(ppp t),(ppp t2)]) 45 | ppp (BeginT l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 46 | ppp (AppT t) = (pppSexp [(ppp t)]) 47 | instance PP Pred where 48 | pp (TrueP) = (ppSexp [fromByteString "true"]) 49 | pp (FalseP) = (ppSexp [fromByteString "false"]) 50 | pp (IfP p p2 p3) = (ppSexp [fromByteString "if",(pp p),(pp p2),(pp p3)]) 51 | pp (BeginP l p) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp p)]))) 52 | pp (AppP r t t2) = (ppSexp [(pp r),(pp t),(pp t2)]) 53 | ppp (TrueP) = (pppSexp [text "true"]) 54 | ppp (FalseP) = (pppSexp [text "false"]) 55 | ppp (IfP p p2 p3) = (pppSexp [text "if",(ppp p),(ppp p2),(ppp p3)]) 56 | ppp (BeginP l p) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp p)]))) 57 | ppp (AppP r t t2) = (pppSexp [(ppp r),(ppp t),(ppp t2)]) 58 | instance PP Effect where 59 | pp (Nop) = (ppSexp [fromByteString "nop"]) 60 | pp (IfE p e e2) = (ppSexp [fromByteString "if",(pp p),(pp e),(pp e2)]) 61 | pp (BeginE l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 62 | pp (ReturnPoint l t) = (ppSexp [fromByteString "return-point",(pp l),(pp t)]) 63 | pp (Set1 l t) = (ppSexp [fromByteString "set!",(pp l),(pp t)]) 64 | pp (Set2 l b t t2) = (ppSexp [fromByteString "set!",(pp l),(ppSexp [(pp b),(pp t),(pp t2)])]) 65 | ppp (Nop) = (pppSexp [text "nop"]) 66 | ppp (IfE p e e2) = (pppSexp [text "if",(ppp p),(ppp e),(ppp e2)]) 67 | ppp (BeginE l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 68 | ppp (ReturnPoint l t) = (pppSexp [text "return-point",(ppp l),(ppp t)]) 69 | ppp (Set1 l t) = (pppSexp [text "set!",(ppp l),(ppp t)]) 70 | ppp (Set2 l b t t2) = (pppSexp [text "set!",(ppp l),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 71 | instance PP Triv where 72 | pp (Integer i) = (pp i) 73 | pp (Label l) = (pp l) 74 | pp (Loc l) = (pp l) 75 | ppp (Integer i) = (ppp i) 76 | ppp (Label l) = (ppp l) 77 | ppp (Loc l) = (ppp l) 78 | instance PP Prog where 79 | pp (Letrec l t) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,t) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp t)])])) l)),(pp t)]) 80 | ppp (Letrec l t) = (pppSexp [text "letrec",(pppSexp (map (\(l,t) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp t)])])) l)),(ppp t)]) 81 | instance PP Loc where 82 | pp (Reg r) = (pp r) 83 | pp (Disp d) = (pp d) 84 | pp (Ind i) = (pp i) 85 | ppp (Reg r) = (ppp r) 86 | ppp (Disp d) = (ppp d) 87 | ppp (Ind i) = (ppp i) 88 | 89 | deriving instance Eq Tail 90 | deriving instance Read Tail 91 | deriving instance Show Tail 92 | deriving instance Ord Tail 93 | deriving instance Eq Pred 94 | deriving instance Read Pred 95 | deriving instance Show Pred 96 | deriving instance Ord Pred 97 | deriving instance Eq Effect 98 | deriving instance Read Effect 99 | deriving instance Show Effect 100 | deriving instance Ord Effect 101 | deriving instance Eq Triv 102 | deriving instance Read Triv 103 | deriving instance Show Triv 104 | deriving instance Ord Triv 105 | deriving instance Eq Prog 106 | deriving instance Read Prog 107 | deriving instance Show Prog 108 | deriving instance Ord Prog 109 | deriving instance Eq Loc 110 | deriving instance Read Loc 111 | deriving instance Show Loc 112 | deriving instance Ord Loc 113 | 114 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L39ExposeBasicBlocks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L39ExposeBasicBlocks where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Tail 13 | = Begin [Effect] Tail 14 | | App Triv 15 | | If Relop Triv Triv Label Label 16 | data Effect 17 | = Set1 Loc Triv 18 | | Set2 Loc Binop Triv Triv 19 | data Triv 20 | = Integer Integer 21 | | Label Label 22 | | Loc Loc 23 | data Prog 24 | = Letrec [(Label,Tail)] Tail 25 | data Loc 26 | = Reg Reg 27 | | Disp Disp 28 | | Ind Ind 29 | 30 | instance PP Tail where 31 | pp (Begin l t) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp t)]))) 32 | pp (App t) = (ppSexp [(pp t)]) 33 | pp (If r t t2 l l2) = (ppSexp [fromByteString "if",(ppSexp [(pp r),(pp t),(pp t2)]),(ppSexp [(pp l)]),(ppSexp [(pp l2)])]) 34 | ppp (Begin l t) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp t)]))) 35 | ppp (App t) = (pppSexp [(ppp t)]) 36 | ppp (If r t t2 l l2) = (pppSexp [text "if",(pppSexp [(ppp r),(ppp t),(ppp t2)]),(pppSexp [(ppp l)]),(pppSexp [(ppp l2)])]) 37 | instance PP Effect where 38 | pp (Set1 l t) = (ppSexp [fromByteString "set!",(pp l),(pp t)]) 39 | pp (Set2 l b t t2) = (ppSexp [fromByteString "set!",(pp l),(ppSexp [(pp b),(pp t),(pp t2)])]) 40 | ppp (Set1 l t) = (pppSexp [text "set!",(ppp l),(ppp t)]) 41 | ppp (Set2 l b t t2) = (pppSexp [text "set!",(ppp l),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 42 | instance PP Triv where 43 | pp (Integer i) = (pp i) 44 | pp (Label l) = (pp l) 45 | pp (Loc l) = (pp l) 46 | ppp (Integer i) = (ppp i) 47 | ppp (Label l) = (ppp l) 48 | ppp (Loc l) = (ppp l) 49 | instance PP Prog where 50 | pp (Letrec l t) = (ppSexp [fromByteString "letrec",(ppSexp (map (\(l,t) -> (ppSexp [(pp l),(ppSexp [fromByteString "lambda",(ppSexp []),(pp t)])])) l)),(pp t)]) 51 | ppp (Letrec l t) = (pppSexp [text "letrec",(pppSexp (map (\(l,t) -> (pppSexp [(ppp l),(pppSexp [text "lambda",(pppSexp []),(ppp t)])])) l)),(ppp t)]) 52 | instance PP Loc where 53 | pp (Reg r) = (pp r) 54 | pp (Disp d) = (pp d) 55 | pp (Ind i) = (pp i) 56 | ppp (Reg r) = (ppp r) 57 | ppp (Disp d) = (ppp d) 58 | ppp (Ind i) = (ppp i) 59 | 60 | deriving instance Eq Tail 61 | deriving instance Read Tail 62 | deriving instance Show Tail 63 | deriving instance Ord Tail 64 | deriving instance Eq Effect 65 | deriving instance Read Effect 66 | deriving instance Show Effect 67 | deriving instance Ord Effect 68 | deriving instance Eq Triv 69 | deriving instance Read Triv 70 | deriving instance Show Triv 71 | deriving instance Ord Triv 72 | deriving instance Eq Prog 73 | deriving instance Read Prog 74 | deriving instance Show Prog 75 | deriving instance Ord Prog 76 | deriving instance Eq Loc 77 | deriving instance Read Loc 78 | deriving instance Show Loc 79 | deriving instance Ord Loc 80 | 81 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/GenGrammars/L41FlattenProgram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.L41FlattenProgram where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Statement 13 | = Set1 Loc Triv 14 | | Set2 Loc Binop Triv Triv 15 | | If1 Relop Triv Triv Label 16 | | If2 Relop Triv Triv Label 17 | | Jump Triv 18 | | LabelS Label 19 | data Triv 20 | = Integer Integer 21 | | LabelT Label 22 | | Loc Loc 23 | data Loc 24 | = Reg Reg 25 | | Disp Disp 26 | | Ind Ind 27 | data Prog 28 | = Code [Statement] Statement 29 | 30 | instance PP Statement where 31 | pp (Set1 l t) = (ppSexp [fromByteString "set!",(pp l),(pp t)]) 32 | pp (Set2 l b t t2) = (ppSexp [fromByteString "set!",(pp l),(ppSexp [(pp b),(pp t),(pp t2)])]) 33 | pp (If1 r t t2 l) = (ppSexp [fromByteString "if",(ppSexp [(pp r),(pp t),(pp t2)]),(ppSexp [fromByteString "jump",(pp l)])]) 34 | pp (If2 r t t2 l) = (ppSexp [fromByteString "if",(ppSexp [fromByteString "not",(ppSexp [(pp r),(pp t),(pp t2)])]),(ppSexp [fromByteString "jump",(pp l)])]) 35 | pp (Jump t) = (ppSexp [fromByteString "jump",(pp t)]) 36 | pp (LabelS l) = (pp l) 37 | ppp (Set1 l t) = (pppSexp [text "set!",(ppp l),(ppp t)]) 38 | ppp (Set2 l b t t2) = (pppSexp [text "set!",(ppp l),(pppSexp [(ppp b),(ppp t),(ppp t2)])]) 39 | ppp (If1 r t t2 l) = (pppSexp [text "if",(pppSexp [(ppp r),(ppp t),(ppp t2)]),(pppSexp [text "jump",(ppp l)])]) 40 | ppp (If2 r t t2 l) = (pppSexp [text "if",(pppSexp [text "not",(pppSexp [(ppp r),(ppp t),(ppp t2)])]),(pppSexp [text "jump",(ppp l)])]) 41 | ppp (Jump t) = (pppSexp [text "jump",(ppp t)]) 42 | ppp (LabelS l) = (ppp l) 43 | instance PP Triv where 44 | pp (Integer i) = (pp i) 45 | pp (LabelT l) = (pp l) 46 | pp (Loc l) = (pp l) 47 | ppp (Integer i) = (ppp i) 48 | ppp (LabelT l) = (ppp l) 49 | ppp (Loc l) = (ppp l) 50 | instance PP Loc where 51 | pp (Reg r) = (pp r) 52 | pp (Disp d) = (pp d) 53 | pp (Ind i) = (pp i) 54 | ppp (Reg r) = (ppp r) 55 | ppp (Disp d) = (ppp d) 56 | ppp (Ind i) = (ppp i) 57 | instance PP Prog where 58 | pp (Code l s) = (ppSexp (fromByteString "code" : ((map pp l) ++ [(pp s)]))) 59 | ppp (Code l s) = (pppSexp (text "code" : ((map ppp l) ++ [(ppp s)]))) 60 | 61 | deriving instance Eq Statement 62 | deriving instance Read Statement 63 | deriving instance Show Statement 64 | deriving instance Ord Statement 65 | deriving instance Eq Triv 66 | deriving instance Read Triv 67 | deriving instance Show Triv 68 | deriving instance Ord Triv 69 | deriving instance Eq Loc 70 | deriving instance Read Loc 71 | deriving instance Show Loc 72 | deriving instance Ord Loc 73 | deriving instance Eq Prog 74 | deriving instance Read Prog 75 | deriving instance Show Prog 76 | deriving instance Ord Prog 77 | 78 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/FrameworkHs/Prims.hs: -------------------------------------------------------------------------------- 1 | 2 | module FrameworkHs.Prims 3 | ( UVar (..) 4 | , FVar (..) 5 | , Label (..) 6 | , Reg (..), numRegisters, allRegisters 7 | , Relop (..) 8 | , Binop (..) 9 | , Disp (..) 10 | , Ind (..) 11 | , LooseEq(..) 12 | , PredPrim(..), EffectPrim (..), ValPrim(..) 13 | , valPrimArity, effectPrimArity, predPrimArity 14 | , Immediate(..) 15 | , Datum(..) 16 | ) 17 | where 18 | 19 | import Prelude as P hiding (LT, EQ, GT) 20 | import Data.Int 21 | import Data.Symbol 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Terminal Type Definitions --------------------------------------------------- 25 | 26 | data UVar = UV String Integer deriving (Read, Show, Eq, Ord) 27 | data Label = L String Integer deriving (Read, Show, Eq, Ord) 28 | data FVar = FV Integer deriving (Read, Show, Eq, Ord) 29 | 30 | data UVar' = UV' Symbol Integer deriving (Show, Eq, Ord) 31 | data Label' = L' Symbol Integer deriving (Show, Eq, Ord) 32 | 33 | -- | use a loose equality test that only test the suffix of a uvar or label 34 | -- rather than testing the Symbol and the Integer for equality. 35 | class LooseEq a where 36 | (.=) :: a -> a -> Bool 37 | 38 | instance LooseEq UVar where 39 | (UV var1 suffix1) .= (UV var2 suffix2) = suffix1 P.== suffix2 40 | 41 | instance LooseEq Label where 42 | (L var1 suffix1) .= (L var2 suffix2) = suffix1 P.== suffix2 43 | 44 | instance LooseEq UVar' where 45 | (UV' var1 suffix1) .= (UV' var2 suffix2) = suffix1 P.== suffix2 46 | 47 | instance LooseEq Label' where 48 | (L' var1 suffix1) .= (L' var2 suffix2) = suffix1 P.== suffix2 49 | 50 | 51 | data Reg = RAX | RCX | RDX | RBX | RBP | RSI | RDI | R8 | R9 52 | | R10 | R11 | R12 | R13 | R14 | R15 53 | deriving (Read,Show,Eq,Ord, Bounded, Enum) 54 | 55 | allRegisters :: [Reg] 56 | allRegisters = [minBound .. maxBound] 57 | 58 | numRegisters :: Int 59 | numRegisters = 1 + fromEnum (maxBound :: Reg) - fromEnum (minBound :: Reg) 60 | 61 | -- Low Level machine primitives: 62 | ---------------------------------------- 63 | 64 | data Relop = LT | LTE | EQ | GT | GTE deriving (Read,Show,Eq,Ord) 65 | data Binop = MUL | ADD | SUB | LOGAND | LOGOR | SRA deriving (Read,Show,Eq,Ord) 66 | 67 | data Disp = D Reg Integer deriving (Read,Show,Eq, Ord) 68 | data Ind = I Reg Reg deriving (Read,Show,Eq, Ord) 69 | 70 | 71 | -- High-level Scheme primitives: 72 | ---------------------------------------- 73 | 74 | data PredPrim = Lt | Lte | Eq | Gte | Gt 75 | | BooleanP | EqP | FixnumP | NullP | PairP | VectorP | ProcedureP 76 | deriving (Read, Show, Eq, Ord) 77 | 78 | data EffectPrim = SetCar | SetCdr | VectorSet | ProcedureSet 79 | deriving (Read, Show, Eq, Ord) 80 | 81 | data ValPrim = Times | Plus | Minus | Car | Cdr | Cons 82 | | MakeVector | VectorLength | VectorRef | Void 83 | | MakeProcedure | ProcedureCode | ProcedureRef 84 | deriving (Read, Show, Eq, Ord) 85 | 86 | valPrimArity :: ValPrim -> Int 87 | valPrimArity vp = 88 | case vp of 89 | Times -> 2 ; Plus -> 2 ; Minus -> 2 ; Car -> 1 ; Cdr -> 1 ; Cons -> 2 90 | MakeVector -> 1 ; VectorLength -> 1 ; VectorRef -> 2 ; Void -> 0 ; MakeProcedure -> 2 91 | ProcedureCode -> 1 ; ProcedureRef -> 2 92 | 93 | predPrimArity :: PredPrim -> Int 94 | predPrimArity pp = 95 | case pp of 96 | Lt -> 2 ; Lte -> 2 ; Eq -> 2 ; Gte -> 2 ; Gt -> 2 97 | BooleanP -> 1 ; EqP -> 2 ; FixnumP -> 1 ; NullP -> 1 ; PairP -> 1 ; VectorP -> 1 98 | ProcedureP -> 1 99 | 100 | effectPrimArity :: EffectPrim -> Int 101 | effectPrimArity ep = 102 | case ep of 103 | SetCar -> 2 ; SetCdr -> 2 ; VectorSet -> 3 ; ProcedureSet -> 3 104 | 105 | data Immediate = Fixnum Int64 | NullList | HashT | HashF 106 | deriving (Read, Show, Eq, Ord) 107 | 108 | data Datum = PairDatum Datum Datum 109 | | VectorDatum [Datum] 110 | | ImmediateDatum Immediate 111 | deriving (Read, Show, Eq, Ord) 112 | -------------------------------------------------------------------------------- /middle_end/nanopass/course_example/nanopass-sample.cabal: -------------------------------------------------------------------------------- 1 | Name: nanopass-sample 2 | Version: 0.0.1 3 | Synopsis: A peek at part of the P423 class compiler framework. 4 | Author: Ryan R. Newton 5 | Maintainer: rrnewton@gmail.com 6 | Category: Language 7 | Build-type: Simple 8 | 9 | -- Constraint on the version of Cabal needed to build this package: 10 | Cabal-version: >=1.10 11 | 12 | Library 13 | Exposed-modules: 14 | -- CompilerHs.Compile 15 | FrameworkHs.Helpers 16 | -- FrameworkHs.Driver 17 | FrameworkHs.Prims 18 | -- FrameworkHs.Testing 19 | FrameworkHs.SExpReader.LispData 20 | FrameworkHs.SExpReader.Parser 21 | -- FrameworkHs.ParseL01 22 | -- FrameworkHs.GenGrammars.L01VerifyScheme 23 | 24 | FrameworkHs.GenGrammars.L00VerifyScheme 25 | FrameworkHs.GenGrammars.L01ParseScheme 26 | FrameworkHs.GenGrammars.L02ConvertComplexDatum 27 | FrameworkHs.GenGrammars.L03UncoverAssigned 28 | FrameworkHs.GenGrammars.L04PurifyLetrec 29 | FrameworkHs.GenGrammars.L05ConvertAssignments 30 | FrameworkHs.GenGrammars.L07RemoveAnonymousLambda 31 | FrameworkHs.GenGrammars.L08SanitizeBindings 32 | FrameworkHs.GenGrammars.L09UncoverFree 33 | FrameworkHs.GenGrammars.L10ConvertClosures 34 | FrameworkHs.GenGrammars.L12UncoverWellKnown 35 | FrameworkHs.GenGrammars.L15IntroduceProcedurePrimitives 36 | FrameworkHs.GenGrammars.L17LiftLetrec 37 | FrameworkHs.GenGrammars.L18NormalizeContext 38 | FrameworkHs.GenGrammars.L19SpecifyRepresentation 39 | FrameworkHs.GenGrammars.L20UncoverLocals 40 | FrameworkHs.GenGrammars.L22VerifyUil 41 | FrameworkHs.GenGrammars.L23RemoveComplexOpera 42 | FrameworkHs.GenGrammars.L24FlattenSet 43 | FrameworkHs.GenGrammars.L25ImposeCallingConventions 44 | FrameworkHs.GenGrammars.L26ExposeAllocationPointer 45 | FrameworkHs.GenGrammars.L27UncoverFrameConflict 46 | FrameworkHs.GenGrammars.L28PreAssignFrame 47 | FrameworkHs.GenGrammars.L29AssignNewFrame 48 | FrameworkHs.GenGrammars.L30FinalizeFrameLocations 49 | FrameworkHs.GenGrammars.L32UncoverRegisterConflict 50 | FrameworkHs.GenGrammars.L33AssignRegisters 51 | FrameworkHs.GenGrammars.L35DiscardCallLive 52 | FrameworkHs.GenGrammars.L36FinalizeLocations 53 | FrameworkHs.GenGrammars.L37ExposeFrameVar 54 | FrameworkHs.GenGrammars.L38ExposeMemoryOperands 55 | FrameworkHs.GenGrammars.L39ExposeBasicBlocks 56 | FrameworkHs.GenGrammars.L41FlattenProgram 57 | 58 | default-language: Haskell2010 59 | build-depends: 60 | base == 4.*, deepseq == 1.3.*, vector >= 0.10, containers, process, pretty, 61 | symbol, mtl >= 2, parsec >=3, bytestring >= 0.10, blaze-builder 62 | -------------------------------------------------------------------------------- /middle_end/nanopass/exercise/FrameworkHs/GenGrammars/MicroScheme.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.MicroScheme where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = ExprP Expr 14 | data Expr 15 | = Immediate Immediate 16 | | Quote Datum 17 | | Let [(UVar,Expr)] [Body] 18 | | Lambda [UVar] [Body] 19 | | If Expr Expr Expr 20 | | Begin [Expr] Expr 21 | | Set UVar Expr 22 | | App1 ValPrim [Expr] 23 | | App2 EffectPrim [Expr] 24 | | App3 PredPrim [Expr] 25 | | App4 Expr [Expr] 26 | | UVar UVar 27 | data Body 28 | = ExprB Expr 29 | 30 | instance PP Prog where 31 | pp (ExprP e) = (pp e) 32 | ppp (ExprP e) = (ppp e) 33 | instance PP Expr where 34 | pp (Immediate i) = (pp i) 35 | pp (Quote d) = (ppSexp [fromByteString "quote",(pp d)]) 36 | pp (Let l l2) = (ppSexp (fromByteString "let" : ((ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)) : (map pp l2)))) 37 | pp (Lambda l l2) = (ppSexp (fromByteString "lambda" : ((ppSexp (map pp l)) : (map pp l2)))) 38 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 39 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 40 | pp (Set u e) = (ppSexp [fromByteString "set!",(pp u),(pp e)]) 41 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 42 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 43 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 44 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 45 | pp (UVar u) = (pp u) 46 | ppp (Immediate i) = (ppp i) 47 | ppp (Quote d) = (pppSexp [text "quote",(ppp d)]) 48 | ppp (Let l l2) = (pppSexp (text "let" : ((pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)) : (map ppp l2)))) 49 | ppp (Lambda l l2) = (pppSexp (text "lambda" : ((pppSexp (map ppp l)) : (map ppp l2)))) 50 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 51 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 52 | ppp (Set u e) = (pppSexp [text "set!",(ppp u),(ppp e)]) 53 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 54 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 55 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 56 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 57 | ppp (UVar u) = (ppp u) 58 | instance PP Body where 59 | pp (ExprB e) = (pp e) 60 | ppp (ExprB e) = (ppp e) 61 | 62 | deriving instance Eq Prog 63 | deriving instance Read Prog 64 | deriving instance Show Prog 65 | deriving instance Ord Prog 66 | deriving instance Eq Expr 67 | deriving instance Read Expr 68 | deriving instance Show Expr 69 | deriving instance Ord Expr 70 | deriving instance Eq Body 71 | deriving instance Read Body 72 | deriving instance Show Body 73 | deriving instance Ord Body 74 | 75 | -------------------------------------------------------------------------------- /middle_end/nanopass/exercise/FrameworkHs/GenGrammars/NoLets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | 5 | module FrameworkHs.GenGrammars.NoLets where 6 | 7 | import FrameworkHs.Prims 8 | import FrameworkHs.Helpers 9 | import Text.PrettyPrint.HughesPJ (text) 10 | import Blaze.ByteString.Builder (fromByteString) 11 | 12 | data Prog 13 | = ExprP Expr 14 | data Expr 15 | = Immediate Immediate 16 | | Quote Datum 17 | | Let [(UVar,Expr)] [Body] 18 | | Lambda [UVar] [Body] 19 | | If Expr Expr Expr 20 | | Begin [Expr] Expr 21 | | Set UVar Expr 22 | | App1 ValPrim [Expr] 23 | | App2 EffectPrim [Expr] 24 | | App3 PredPrim [Expr] 25 | | App4 Expr [Expr] 26 | | UVar UVar 27 | data Body 28 | = ExprB Expr 29 | 30 | instance PP Prog where 31 | pp (ExprP e) = (pp e) 32 | ppp (ExprP e) = (ppp e) 33 | instance PP Expr where 34 | pp (Immediate i) = (pp i) 35 | pp (Quote d) = (ppSexp [fromByteString "quote",(pp d)]) 36 | pp (Let l l2) = (ppSexp (fromByteString "let" : ((ppSexp (map (\(u,e) -> (ppSexp [(pp u),(pp e)])) l)) : (map pp l2)))) 37 | pp (Lambda l l2) = (ppSexp (fromByteString "lambda" : ((ppSexp (map pp l)) : (map pp l2)))) 38 | pp (If e e2 e3) = (ppSexp [fromByteString "if",(pp e),(pp e2),(pp e3)]) 39 | pp (Begin l e) = (ppSexp (fromByteString "begin" : ((map pp l) ++ [(pp e)]))) 40 | pp (Set u e) = (ppSexp [fromByteString "set!",(pp u),(pp e)]) 41 | pp (App1 v l) = (ppSexp ((pp v) : (map pp l))) 42 | pp (App2 e l) = (ppSexp ((pp e) : (map pp l))) 43 | pp (App3 p l) = (ppSexp ((pp p) : (map pp l))) 44 | pp (App4 e l) = (ppSexp ((pp e) : (map pp l))) 45 | pp (UVar u) = (pp u) 46 | ppp (Immediate i) = (ppp i) 47 | ppp (Quote d) = (pppSexp [text "quote",(ppp d)]) 48 | ppp (Let l l2) = (pppSexp (text "let" : ((pppSexp (map (\(u,e) -> (pppSexp [(ppp u),(ppp e)])) l)) : (map ppp l2)))) 49 | ppp (Lambda l l2) = (pppSexp (text "lambda" : ((pppSexp (map ppp l)) : (map ppp l2)))) 50 | ppp (If e e2 e3) = (pppSexp [text "if",(ppp e),(ppp e2),(ppp e3)]) 51 | ppp (Begin l e) = (pppSexp (text "begin" : ((map ppp l) ++ [(ppp e)]))) 52 | ppp (Set u e) = (pppSexp [text "set!",(ppp u),(ppp e)]) 53 | ppp (App1 v l) = (pppSexp ((ppp v) : (map ppp l))) 54 | ppp (App2 e l) = (pppSexp ((ppp e) : (map ppp l))) 55 | ppp (App3 p l) = (pppSexp ((ppp p) : (map ppp l))) 56 | ppp (App4 e l) = (pppSexp ((ppp e) : (map ppp l))) 57 | ppp (UVar u) = (ppp u) 58 | instance PP Body where 59 | pp (ExprB e) = (pp e) 60 | ppp (ExprB e) = (ppp e) 61 | 62 | deriving instance Eq Prog 63 | deriving instance Read Prog 64 | deriving instance Show Prog 65 | deriving instance Ord Prog 66 | deriving instance Eq Expr 67 | deriving instance Read Expr 68 | deriving instance Show Expr 69 | deriving instance Ord Expr 70 | deriving instance Eq Body 71 | deriving instance Read Body 72 | deriving instance Show Body 73 | deriving instance Ord Body 74 | 75 | -------------------------------------------------------------------------------- /middle_end/nanopass/exercise/FrameworkHs/Helpers.hs: -------------------------------------------------------------------------------- 1 | ../../course_example/FrameworkHs/Helpers.hs -------------------------------------------------------------------------------- /middle_end/nanopass/exercise/FrameworkHs/Prims.hs: -------------------------------------------------------------------------------- 1 | ../../course_example/FrameworkHs/Prims.hs -------------------------------------------------------------------------------- /middle_end/nanopass/exercise/FrameworkHs/SExpReader: -------------------------------------------------------------------------------- 1 | ../../course_example/FrameworkHs/SExpReader/ -------------------------------------------------------------------------------- /middle_end/nanopass/exercise/RemoveLet.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | module RemoveLet where 4 | 5 | import FrameworkHs.GenGrammars.MicroScheme as S 6 | import qualified FrameworkHs.GenGrammars.NoLets as T 7 | 8 | 9 | removeLet :: S.Expr -> T.Expr 10 | removeLet e0 = 11 | case e0 of 12 | (Immediate x) -> T.Immediate x 13 | (Quote x) -> T.Quote x 14 | -- (Let ls bods) -> T.Let [(v,go r) | (v,r) <- ls] 15 | -- (goBods bods) 16 | (Let ls bods) -> let (vs,rhss) = unzip ls 17 | in T.App4 (T.Lambda vs (goBods bods)) 18 | (map go rhss) 19 | 20 | (Lambda ls x2) -> T.Lambda ls (goBods x2) 21 | (If x1 x2 x3) -> T.If (go x1) (go x2) (go x3) 22 | (Begin x1 x2) -> T.Begin (map go x1) (go x2) 23 | (Set x1 x2) -> T.Set x1 (go x2) 24 | (App1 x1 x2) -> T.App1 x1 (map go x2) 25 | (App2 x1 x2) -> T.App2 x1 (map go x2) 26 | (App3 x1 x2) -> T.App3 x1 (map go x2) 27 | (App4 x1 x2) -> T.App4 (go x1) (map go x2) 28 | (UVar x) -> T.UVar x 29 | where 30 | goBods bods = [ (T.ExprB (go bod)) | (ExprB bod) <- bods ] 31 | go = removeLet 32 | -------------------------------------------------------------------------------- /middle_end/nanopass/exercise/grammar-list.ss: -------------------------------------------------------------------------------- 1 | 2 | 3 | (p423-grammars 4 | 5 | (micro-scheme 6 | (start Prog) 7 | (Prog Expr) 8 | (Expr 9 | Immediate 10 | (quote Datum) 11 | (let ([UVar Expr] *) Body *) 12 | (lambda (UVar *) Body *) 13 | (if Expr Expr Expr) 14 | (begin Expr * Expr) 15 | (set! UVar Expr) 16 | (ValPrim Expr *) 17 | (EffectPrim Expr *) 18 | (PredPrim Expr *) 19 | (Expr Expr *) 20 | UVar 21 | ) 22 | (Body Expr) 23 | ) 24 | 25 | (no-lets 26 | (%remove let) 27 | (%add )) 28 | ) 29 | -------------------------------------------------------------------------------- /middle_end/nanopass/exercise/nanopass-exercise.cabal: -------------------------------------------------------------------------------- 1 | Name: nanopass-exercise 2 | Version: 0.0.1 3 | Author: Ryan R. Newton 4 | Maintainer: rrnewton@gmail.com 5 | Category: Language 6 | Build-type: Simple 7 | Cabal-version: >=1.10 8 | 9 | Library 10 | Exposed-modules: 11 | 12 | -- We will write this simple compiler pass: 13 | RemoveLet 14 | 15 | FrameworkHs.Helpers 16 | FrameworkHs.Prims 17 | FrameworkHs.SExpReader.LispData 18 | FrameworkHs.SExpReader.Parser 19 | 20 | FrameworkHs.GenGrammars.MicroScheme 21 | FrameworkHs.GenGrammars.NoLets 22 | 23 | default-language: Haskell2010 24 | build-depends: 25 | base == 4.*, deepseq == 1.3.*, vector >= 0.10, containers, process, pretty, 26 | symbol, mtl >= 2, parsec >=3, bytestring >= 0.10, blaze-builder 27 | -------------------------------------------------------------------------------- /middle_end/syntactic/NanoFeldsparTests.hs: -------------------------------------------------------------------------------- 1 | -- |{-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE GADTs #-} 4 | 5 | -- module NanoFeldsparTests where 6 | module Main where 7 | 8 | import Control.Monad 9 | import Data.List 10 | 11 | import Test.QuickCheck 12 | import Test.Tasty 13 | --import Test.Tasty.Golden 14 | import Test.Tasty.QuickCheck 15 | 16 | import Data.ByteString.Lazy.UTF8 (fromString) 17 | 18 | import Data.Syntactic 19 | import Data.Syntactic.Functional 20 | import qualified NanoFeldspar as Nano 21 | 22 | 23 | 24 | scProd :: [Float] -> [Float] -> Float 25 | scProd as bs = sum $ zipWith (*) as bs 26 | 27 | prop_scProd as bs = scProd as bs == Nano.eval Nano.scProd as bs 28 | 29 | genMat :: Gen [[Float]] 30 | genMat = sized $ \s -> do 31 | x <- liftM succ $ choose (0, s `mod` 10) 32 | y <- liftM succ $ choose (0, s `mod` 10) 33 | replicateM y $ vector x 34 | 35 | forEach = flip map 36 | 37 | matMul :: [[Float]] -> [[Float]] -> [[Float]] 38 | matMul a b = forEach a $ \a' -> 39 | forEach (transpose b) $ \b' -> 40 | scProd a' b' 41 | 42 | prop_matMul = 43 | forAll genMat $ \a -> 44 | forAll genMat $ \b -> 45 | matMul a b == Nano.eval Nano.matMul a b 46 | 47 | -- mkGold_scProd = writeFile "tests/gold/scProd.txt" $ Nano.showAST Nano.scProd 48 | -- mkGold_matMul = writeFile "tests/gold/matMul.txt" $ Nano.showAST Nano.matMul 49 | 50 | alphaRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a 51 | alphaRename = mapAST rename 52 | where 53 | rename :: Nano.FeldDomain a -> Nano.FeldDomain a 54 | rename s 55 | | Just (VarT v) <- prj s = inj (VarT (v+1)) 56 | | Just (LamT v) <- prj s = inj (LamT (v+1)) 57 | | otherwise = s 58 | 59 | badRename :: ASTF Nano.FeldDomain a -> ASTF Nano.FeldDomain a 60 | badRename = mapAST rename 61 | where 62 | rename :: Nano.FeldDomain a -> Nano.FeldDomain a 63 | rename s 64 | | Just (VarT v) <- prj s = inj (VarT (v+1)) 65 | | Just (LamT v) <- prj s = inj (LamT (v-1)) 66 | | otherwise = s 67 | 68 | prop_alphaEq a = alphaEq a (alphaRename a) 69 | 70 | prop_alphaEqBad a = alphaEq a (badRename a) 71 | 72 | tests = testGroup "NanoFeldsparTests" 73 | [ -- goldenVsString "scProd tree" "tests/gold/scProd.txt" $ return $ fromString $ Nano.showAST Nano.scProd 74 | -- , goldenVsString "matMul tree" "tests/gold/matMul.txt" $ return $ fromString $ Nano.showAST Nano.matMul 75 | 76 | testProperty "scProd eval" prop_scProd 77 | , testProperty "matMul eval" prop_matMul 78 | 79 | , testProperty "alphaEq scProd" (prop_alphaEq (desugar Nano.scProd)) 80 | , testProperty "alphaEq matMul" (prop_alphaEq (desugar Nano.matMul)) 81 | , testProperty "alphaEq scProd matMul" (not (alphaEq (desugar Nano.scProd) (desugar Nano.matMul))) 82 | , testProperty "alphaEqBad scProd" (not (prop_alphaEqBad (desugar Nano.scProd))) 83 | , testProperty "alphaEqBad matMul" (not (prop_alphaEqBad (desugar Nano.matMul))) 84 | ] 85 | 86 | main = defaultMain tests 87 | -------------------------------------------------------------------------------- /middle_end/syntactic/nanofeldspar.cabal: -------------------------------------------------------------------------------- 1 | -- Initial nanofeldspar.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: nanofeldspar 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | -- license: 9 | -- license-file: LICENSE 10 | author: 11 | maintainer: 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: NanoFeldspar 20 | -- other-modules: 21 | other-extensions: FlexibleContexts, FlexibleInstances, GADTs, MultiParamTypeClasses, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeOperators, UndecidableInstances 22 | build-depends: base >=4.7 && <4.8, 23 | containers >=0.5 && <0.6, 24 | syntactic 25 | -- hs-source-dirs: 26 | default-language: Haskell2010 27 | 28 | 29 | 30 | executable test-nanofeldspar 31 | main-is: NanoFeldsparTests.hs 32 | default-language: Haskell2010 33 | build-depends: base >=4.7 && <4.8, 34 | containers >=0.5 && <0.6, 35 | syntactic, 36 | bytestring, utf8-string, 37 | tasty-quickcheck, tasty, QuickCheck 38 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - front_end/directive_driven/ 4 | - front_end/overloading/ 5 | - middle_end/GADT_transforms/ 6 | - middle_end/multi-level_AST/ 7 | - middle_end/nanopass/course_example/ 8 | - middle_end/nanopass/exercise/ 9 | - middle_end/syntactic/ 10 | extra-deps: 11 | - syntactic-2.1 12 | - data-hash-0.2.0.1 13 | - wl-pprint-1.2 14 | resolver: lts-2.22 15 | --------------------------------------------------------------------------------