├── test ├── make-do ├── latest ├── latest-svg ├── date-latest-svg ├── figure-svg ├── date-figure-svg ├── makefile ├── Dont.hss ├── DoTreeNoReify.hss ├── DoTree.hss └── fft_test.hs ├── Setup.lhs ├── src ├── .ghci └── LambdaCCC │ ├── Unused │ ├── MkStringExpr.hs │ ├── TransCode.hs │ ├── ToCircuit.hs │ ├── Encode.hs │ ├── Ty.hs │ ├── CoerceEncode.hs │ ├── Standardize.hs │ ├── Standard.hs │ ├── NormalizeCore.hs │ └── ReifyLambda.hs │ ├── Bitonic.hs │ ├── Examples │ └── Linear.hs │ ├── Counters.hs │ ├── Misc.hs │ ├── ShowUtils.hs │ ├── OddEvenSort.hs │ ├── RadixSort.hs │ ├── StateTrie.hs │ ├── Run.hs │ ├── ToCCC.hs │ ├── Adder.hs │ ├── CRC.hs │ ├── Tests.hs │ ├── CCC.hs │ └── ReifySimple.hs ├── Makefile ├── .gitignore ├── doc ├── adding-primitives.md ├── notes.md └── monomorph.md ├── todo.md ├── COPYING ├── lambda-ccc.cabal └── README.md /test/make-do: -------------------------------------------------------------------------------- 1 | (cd ../.. ; make) && make 2 | -------------------------------------------------------------------------------- /test/latest: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cd out; ls -t -1 *.dot | head -1 | sed -e 's/.dot//' 4 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /test/latest-svg: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | if [ "$#" -ne 0 ]; then 3 | echo "Usage: $0" >&2 4 | exit 1 5 | fi 6 | 7 | ./figure-svg `./latest` 8 | -------------------------------------------------------------------------------- /test/date-latest-svg: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ "$#" -ne 1 ]; then 4 | echo "Usage: $0 mm-dd" >&2 5 | exit 1 6 | fi 7 | 8 | ./date-figure-svg $1 `./latest` 9 | -------------------------------------------------------------------------------- /test/figure-svg: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | if [ "$#" -ne 1 ]; then 3 | echo "Usage: $0 pic-name" >&2 4 | exit 1 5 | fi 6 | 7 | ./date-figure-svg `date "+%m-%d"` $1 8 | -------------------------------------------------------------------------------- /src/.ghci: -------------------------------------------------------------------------------- 1 | :set -package ghc 2 | :set -XTemplateHaskell 3 | :set -XMagicHash 4 | :set -fprint-explicit-foralls 5 | -- :set -fprint-explicit-kinds 6 | 7 | -- Experimental, to reduce recompiles. 8 | -- Running the plugin requires recompilation anyway. 9 | 10 | :set -i../../hermit-extras/src 11 | -- :set -i../../circat/src 12 | -- To help when switching between circat and lambda-ccc in Emacs. 13 | :set -package applicative-numbers 14 | -------------------------------------------------------------------------------- /test/date-figure-svg: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ "$#" -ne 2 ]; then 4 | echo "Usage: $0 mm-dd pic-name" >&2 5 | exit 1 6 | fi 7 | 8 | cd out 9 | 10 | if ! [ -e "$2.dot" ]; then 11 | echo "$2.dot not found" >&2 12 | exit 1 13 | fi 14 | 15 | dir="/Users/conal/Tabula/Journal/wikidata/`date +%Y`/Figures" 16 | svg="$1-$2.svg" 17 | 18 | # dot -Tsvg $2.dot -o $dir/$svg && (cd $dir ; ls -l $svg) 19 | dot -Tsvg $2.dot -o $dir/$svg && ls -l $dir/$svg 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | install: 2 | cabal install -j1 --disable-documentation 3 | 4 | run: 5 | hermit test/Simple.hs -opt=LambdaCCC +Main 6 | 7 | demo: 8 | hermit test/Plus.hs -opt=LambdaCCC +Plus 9 | 10 | tags: dist 11 | cd src ; find . -name '*.*hs' | grep -v Junk | grep -v Old | xargs hasktags -e 12 | 13 | # Hack: depend on dist, which updates whenever we build. Is there a standard 14 | # GNU make technique for running a rule whenever the target is called for? 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | Junk* 3 | Old* 4 | dist 5 | Stuff 6 | TAGS 7 | tags 8 | tarballs 9 | out/ 10 | Unused/ 11 | 12 | test/Tests 13 | test/Simple 14 | test/Translate 15 | test/TreeTest 16 | 17 | # Mac OS generates 18 | .DS_Store 19 | 20 | # Where do these files come from? They're not readable. 21 | # For instance, .#Help.page 22 | .#* 23 | 24 | # vim swap files 25 | *.swp 26 | *.swo 27 | 28 | *.hi 29 | *.o 30 | # iverilog result 31 | a.out 32 | 33 | test/Foo.hss 34 | -------------------------------------------------------------------------------- /test/makefile: -------------------------------------------------------------------------------- 1 | HERM = hermit TreeTest.hs -v0 -opt=LambdaCCC.Monomorphize 2 | 3 | doit: 4 | time $(HERM) DoTree.hss resume && ./TreeTest 5 | 6 | reify-done: 7 | echo "" | make reify ; echo 8 | 9 | no-reify-done: 10 | echo "" | make no-reify ; echo 11 | 12 | dont-done: 13 | echo "" | make dont ; echo 14 | 15 | foo-done: 16 | echo "" | make foo ; echo 17 | 18 | reify: 19 | $(HERM) DoTree.hss 20 | 21 | no-reify: 22 | $(HERM) DoTreeNoReify.hss 23 | 24 | dont: 25 | $(HERM) Dont.hss 26 | 27 | foo: 28 | $(HERM) Foo.hss 29 | 30 | compile: 31 | cd ../..; make 32 | 33 | -------------------------------------------------------------------------------- /test/Dont.hss: -------------------------------------------------------------------------------- 1 | -- set-auto-corelint True 2 | set-pp-renderer ascii 3 | set-pp-width 80 4 | 5 | set-pp-type Show 6 | set-pp-coercion Kind 7 | 8 | -- set-pp-type Abstract 9 | -- set-pp-coercion Abstract 10 | 11 | -- set-pp-type Omit 12 | -- set-pp-coercion Omit 13 | 14 | -- down 15 | -- try bash 16 | -- try unshadow 17 | 18 | binding-of 'main 19 | -- Marked INLINE in LambdaCCC.Run, but still needs explicit unfolding here: 20 | try (any-td (unfold ['go,'go','goM,'goM','reifyMealy])) 21 | down ; try simplifyAll' ; up 22 | 23 | -- any-td reify-prep 24 | 25 | -- application-of 'reifyEP 26 | -- down;right;down 27 | -------------------------------------------------------------------------------- /doc/adding-primitives.md: -------------------------------------------------------------------------------- 1 | ## Notes on adding primitive operations and types 2 | 3 | *[Please suggest where more details as needed below.]* 4 | 5 | ### Primitive operations 6 | 7 | * Start with the `Prim` GADT definition in circat's `Circat.Prim`. 8 | * Add a new constructor for your primitive. 9 | * Search the circat and lambda-ccc projects (e.g., using git-grep) for a similar, already-existing `Prim` constructor, and support for your new constructor. 10 | * Compile, and look for errors and warnings, particularly for non-exhaustive or overlapping pattern matching. 11 | 12 | ### Primitive types 13 | 14 | When possible, give a way to interpret your type in terms of simpler types, rather than adding a primitive primitively. 15 | See `Circat.Rep`. 16 | In case you really need a new primitive: 17 | 18 | * Start with the `Lit` GADT definition in circat's `Circat.Prim`. 19 | * Add a new constructor for your primitive type. 20 | * Search for an existing `Lit` constructor in circat and lambda-ccc, and add similar support for your type. 21 | 22 | 23 | ---- 24 | 25 | To explain: 26 | 27 | * `Circat.Classes`: `OkDom` 28 | * `Circat.Circuit`: 29 | * `Buses`. Search for `IntB` references, and add similar. 30 | * `Ty`. Search for `IntT` references, and add similar. 31 | -------------------------------------------------------------------------------- /test/DoTreeNoReify.hss: -------------------------------------------------------------------------------- 1 | set-pp-renderer ascii 2 | set-pp-width 80 3 | 4 | set-pp-type Show 5 | -- set-pp-coercion Show 6 | set-pp-coercion Kind 7 | 8 | -- set-pp-type Omit 9 | -- set-pp-coercion Omit 10 | 11 | binding-of 'main 12 | -- Marked INLINE in LambdaCCC.Run, but still needs explicit unfolding here: 13 | try (any-td (unfold ['go,'go','goSep,'goM,'goM','goMSep,'reifyMealy,'goNew,'goNew'])) 14 | down ; try simplifyAll' ; up 15 | 16 | -- Necessary?? 17 | any-td reify-prep 18 | 19 | -- application-of 'reifyEP 20 | 21 | -- down ; right 22 | 23 | -- try (repeat (any-td (repeat reify-misc))) 24 | -- try bash 25 | -- try unshadow 26 | 27 | ---- 28 | 29 | -- -- TEMP 30 | -- application-of 'reifyEP 31 | 32 | -- reifyPair 33 | -- down;right 34 | 35 | -- down;right 36 | -- any-bu recast 37 | -- simplifyAll 38 | 39 | -- application-of 'prodA 40 | -- passE; passE 41 | -- down ; rhs-of 'liftA2 42 | -- passE -- bombs 43 | 44 | -- one-td monomorphize 45 | -- retypeExprR 46 | -- lint-expr 47 | 48 | -- down;down;down;down;down;down;down 49 | -- -- standardizeCase 50 | 51 | -- rhs-of '<*> 52 | -- down 53 | -- monomorphize 54 | -- rhs-of 'ap'1 ; down 55 | -- standardizeCase 56 | 57 | -- application-of 'reifyEP; down;right 58 | -- passE 59 | 60 | -- application-of 'reifyEP 61 | -- reify-prep 62 | -------------------------------------------------------------------------------- /test/DoTree.hss: -------------------------------------------------------------------------------- 1 | set-pp-renderer ascii 2 | set-pp-width 80 3 | 4 | -- set-pp-type Show 5 | -- -- set-pp-coercion Show 6 | -- set-pp-coercion Kind 7 | 8 | set-pp-type Omit 9 | set-pp-coercion Omit 10 | 11 | binding-of 'main 12 | -- Marked INLINE in LambdaCCC.Run, but still needs explicit unfolding here: 13 | try (any-td (unfold ['go,'go','goSep,'goM,'goM','goMSep,'reifyMealy,'goNew,'goNew'])) 14 | down ; try simplifyAll' ; up 15 | 16 | any-td reify-prep 17 | 18 | try (repeat (any-td (repeat reify-misc))) 19 | try bash 20 | try unshadow 21 | 22 | -- -- Generate a run-time error message for remaining reifyEP applications. 23 | -- try (any-td reifyOops) 24 | 25 | ---- 26 | 27 | -- -- TEMP 28 | -- application-of 'reifyEP 29 | 30 | -- reifyPair 31 | -- down;right 32 | 33 | -- down;right 34 | -- any-bu recast 35 | -- simplifyAll 36 | 37 | -- application-of 'prodA 38 | -- passE; passE 39 | -- down ; rhs-of 'liftA2 40 | -- passE -- bombs 41 | 42 | -- one-td monomorphize 43 | -- retypeExprR 44 | -- lint-expr 45 | 46 | -- down;down;down;down;down;down;down 47 | -- -- standardizeCase 48 | 49 | -- rhs-of '<*> 50 | -- down 51 | -- monomorphize 52 | -- rhs-of 'ap'1 ; down 53 | -- standardizeCase 54 | 55 | -- application-of 'reifyEP; down;right 56 | -- passE 57 | 58 | -- application-of 'reifyEP 59 | -- reify-prep 60 | -------------------------------------------------------------------------------- /todo.md: -------------------------------------------------------------------------------- 1 | * Multi-clock systems: 2 | semantic model and implementation. 3 | * Rethink allocation to use sets of spacetime slots. 4 | 5 | * Efficient incremental update. 6 | Use in histogram and counting sort. 7 | * Algorithms: 8 | * Sorting: 9 | * Radix sort 10 | * Larger bitonic sort 11 | * Batcher's odd-even merge sort 12 | * Regular expression matching and other forms of parsing. 13 | Possible tools: 14 | * Languages as star [semirings](https://en.wikipedia.org/wiki/Semiring). 15 | Among other references, see [*A Very General Method of Computing Shortest Paths*]. 16 | * Derivatives of regular languages and beyond. 17 | (See [this StackExchange discussion](https://cstheory.stackexchange.com/questions/3280/generalizations-of-brzozowskis-method-of-derivatives-of-regular-expressions-to) for some pointers.) 18 | * Computation with buffering 19 | * Fast compilation 20 | * Linear algebra via tries. 21 | `forkT` and `joinT`. 22 | * Automatic differentiation for machine learning 23 | * Variable bit width `Int`s 24 | * Streams as first-class values 25 | * Automatically set up data transfers around a circuit, including repetition as in matrix multiplication. 26 | * Learn how to declare RAMs. 27 | Stylus does not automatically choose to use RAMs from `reg` declarations. 28 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/MkStringExpr.hs: -------------------------------------------------------------------------------- 1 | -- {-# LANGUAGE #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 5 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 6 | 7 | ---------------------------------------------------------------------- 8 | -- | 9 | -- Module : LambdaCCC.MkStringExpr 10 | -- Copyright : (c) 2013 Tabula, Inc. 11 | -- LICENSE : BSD3 12 | -- 13 | -- Maintainer : conal@tabula.com 14 | -- Stability : experimental 15 | -- 16 | -- Tweaked mkStringExpr from coreSyn/MkCore in GHC API. The standard version 17 | -- treats empty and single-character strings specially, which makes for less 18 | -- uniform-looking Core. 19 | ---------------------------------------------------------------------- 20 | 21 | module LambdaCCC.MkStringExpr (mkStringExpr) where 22 | 23 | import Control.Monad (liftM) 24 | import Data.Char (ord) 25 | 26 | import GhcPlugins hiding (mkStringExpr) 27 | import PrelNames (unpackCStringName,unpackCStringUtf8Name) 28 | 29 | -- | Create a 'CoreExpr' that evaluates to the given string 30 | mkStringExpr :: MonadThings m => String -> m CoreExpr 31 | mkStringExpr str = liftM mk (lookupId unpackName) 32 | where 33 | mk unpackId = App (Var unpackId) (Lit (mkMachString str)) 34 | unpackName | all safeChar str = unpackCStringName 35 | | otherwise = unpackCStringUtf8Name 36 | safeChar c = ord c >= 1 && ord c <= 0x7F 37 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Tabula Inc 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The names of the authors may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | 26 | -------------------------------------------------------------------------------- /src/LambdaCCC/Bitonic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 5 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 6 | 7 | ---------------------------------------------------------------------- 8 | -- | 9 | -- Module : LambdaCCC.Bitonic 10 | -- Copyright : (c) 2014 Tabula, Inc. 11 | -- 12 | -- Maintainer : conal@tabula.com 13 | -- Stability : experimental 14 | -- 15 | -- Bitonic sort 16 | ---------------------------------------------------------------------- 17 | 18 | module LambdaCCC.Bitonic where 19 | 20 | -- TODO: explicit exports 21 | 22 | import Prelude hiding (reverse) 23 | 24 | import Data.Functor ((<$>)) 25 | import Data.Foldable (toList) 26 | 27 | import TypeUnary.TyNat (N1,N2,N3,N4) 28 | import TypeUnary.Nat (IsNat(..),Nat(..)) 29 | 30 | import Circat.Pair 31 | import Circat.RTree 32 | 33 | import Circat.Misc (Unop,Reversible(..)) 34 | 35 | bsort :: (IsNat n, Ord a) => Unop (RTree n a) 36 | bsort = bsort' nat 37 | {-# INLINE bsort #-} 38 | 39 | bsort' :: Ord a => Nat n -> Unop (RTree n a) 40 | bsort' Zero = id 41 | bsort' (Succ m) = \ (B ts) -> 42 | merge (Succ m) (B (secondP reverse (bsort' m <$> ts))) 43 | {-# INLINE bsort' #-} 44 | 45 | -- Equivalently, 46 | 47 | -- bsort' (Succ m) = \ (B (u :# v)) -> 48 | -- merge (Succ m) (B (bsort' m u :# reverse (bsort' m v))) 49 | 50 | -- Bitonic merge 51 | merge :: Ord a => Nat n -> Unop (RTree n a) 52 | merge n = butterfly' n sortP 53 | {-# INLINE merge #-} 54 | 55 | {-------------------------------------------------------------------- 56 | Tests 57 | --------------------------------------------------------------------} 58 | 59 | test :: (IsNat n, Ord a) => RTree n a -> [a] 60 | test = toList . bsort 61 | 62 | _t1 :: RTree N1 Int 63 | _t1 = tree1 4 3 64 | 65 | _t2 :: RTree N2 Int 66 | _t2 = tree2 4 3 1 5 67 | 68 | _t3 :: RTree N3 Int 69 | _t3 = tree3 4 3 7 1 9 5 2 6 70 | 71 | _t4 :: RTree N4 Int 72 | _t4 = tree4 4 12 3 16 8 11 15 7 1 10 9 14 5 13 2 6 73 | -------------------------------------------------------------------------------- /lambda-ccc.cabal: -------------------------------------------------------------------------------- 1 | Name: lambda-ccc 2 | Version: 0.5 3 | Cabal-Version: >= 1.8 4 | Synopsis: Convert lambda expressions to CCC combinators 5 | Category: language 6 | Description: Convert lambda expressions to CCC combinators 7 | Author: Conal Elliott 8 | Maintainer: conal@conal.net 9 | Homepage: http://github.com/conal/lambda-ccc 10 | Copyright: (c) 2013-2014 by Tabula, Inc 11 | License: BSD3 12 | License-File: COPYING 13 | Stability: experimental 14 | build-type: Simple 15 | 16 | Extra-Source-Files: 17 | test/Tests.hs 18 | test/Tests.hss 19 | 20 | source-repository head 21 | type: git 22 | location: git://github.com/conal/lambda-ccc 23 | 24 | Library 25 | hs-Source-Dirs: src/ 26 | Build-Depends: base < 5 27 | , ghc >= 7.6 28 | , ghc-prim 29 | , transformers 30 | , mtl 31 | , containers 32 | , kure >= 2.16.0 33 | , hermit >= 0.5.0.1 34 | , ty >= 0.1.5 35 | , type-unary >= 0.2.21 36 | , circat >= 0.6.3 37 | , hermit-extras >= 0.2.2 38 | , MemoTrie 39 | , QuickCheck >= 2.7.3 40 | 41 | Exposed-Modules: LambdaCCC.Misc 42 | LambdaCCC.ShowUtils 43 | LambdaCCC.Lambda 44 | LambdaCCC.ToCCC 45 | LambdaCCC.Monomorphize 46 | LambdaCCC.ReifySimple 47 | LambdaCCC.Run 48 | LambdaCCC.StateTrie 49 | LambdaCCC.Adder 50 | LambdaCCC.CRC 51 | LambdaCCC.Bitonic 52 | LambdaCCC.RadixSort 53 | LambdaCCC.Counters 54 | Other-Modules: 55 | LambdaCCC.Tests 56 | 57 | -- Test-Suite test1 58 | -- hs-Source-Dirs: test 59 | -- type: exitcode-stdio-1.0 60 | -- main-is: SimpleMain.hs 61 | -- build-depends: base, circat, lambda-ccc 62 | 63 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Convert lambda expressions to CCC combinators and then to circuits. 2 | 3 | Additional info: 4 | 5 | * [Project notes](doc/notes.md). 6 | * The talk [From Haskell to Hardware via CCCs](https://github.com/conal/talk-2015-haskell-to-hardware). 7 | * Instructions in test/Tests.hs. 8 | 9 | Dependencies: 10 | 11 | * GHC 7.8.2 or better 12 | * KURE, [commit 7ce26aa](https://github.com/ku-fpg/kure/commit/7ce26aa) 13 | * HERMIT, [commit 5557609](https://github.com/ku-fpg/hermit/commit/5557609) 14 | * [hermit-extras](http://github.com/conal/hermit-extras) 15 | * [circat](https://github.com/conal/circat), for circuit specification, display, and conversion to netlists. 16 | 17 | To use these versions of KURE and HERMIT, clone the repos (or pull if already cloned), and use "git checkout [commit-id]". 18 | 19 | To try out: 20 | 21 | * `cabal install` circat and lambda-ccc (in that order) 22 | * In a shell, `cd` to lambda-ccc/test, and type `make`. 23 | If all works, you'll see something like the following output: 24 | 25 | bash-3.2$ ./test 26 | [starting HERMIT v0.5.0.1 on TreeTest.hs] 27 | % ghc TreeTest.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fexpose-all-unfoldings -fplugin=LambdaCCC.Monomorphize -fplugin-opt=LambdaCCC.Monomorphize:-v0 -fplugin-opt=LambdaCCC.Monomorphize:DoTree.hss -fplugin-opt=LambdaCCC.Monomorphize:resume -fplugin-opt=LambdaCCC.Monomorphize:*: -v0 28 | 29 | real 0m6.098s 30 | user 0m5.968s 31 | sys 0m0.245s 32 | let f = \ ds -> abst (repr ds) in let f0 = \ ds -> let (a1,a'1) = repr (repr ds) in abst (repr (f a1) + repr (f a'1)) in let f1 = \ ds -> let (a1,a'1) = repr (repr ds) in abst (repr (f0 a1) + repr (f0 a'1)) in let f2 = \ eta -> let a = repr eta in abst (a * a) in let f3 = \ eta -> abst (let (a1,a'1) = repr (repr eta) in abst (f2 a1,f2 a'1)) in let f4 = \ eta -> abst (let (a1,a'1) = repr (repr eta) in abst (f3 a1,f3 a'1)) in \ x -> let (a1,a'1) = repr (let (a1,a'1) = repr (repr x) in abst (f4 a1,f4 a'1)) in repr (f1 a1) + repr (f1 a'1) 33 | Wrote out/sumSquare-t3.pdf 34 | Wrote out/sumSquare-t3.v.txt 35 | 36 | The `.v.txt` file is Verilog code. Additionally the PDF will be displayed if the display code figures out how to on your system. 37 | 38 | There are many other examples in `test/TreeTest.hs`. At any time, all examples but one are commented out. 39 | 40 | -------------------------------------------------------------------------------- /src/LambdaCCC/Examples/Linear.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 5 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 6 | 7 | -- Whether to use trees instead of vectors. 8 | -- Restricts to power-of-two, and gives fast fold for dot. 9 | 10 | -- #define UseTrees 11 | 12 | module LambdaCCC.Examples.Linear where 13 | 14 | import Prelude hiding (sum) 15 | import Data.Foldable (Foldable(..),sum) 16 | import Data.Traversable (Traversable(..)) 17 | import Control.Applicative (Applicative,liftA2) 18 | 19 | {- 20 | -- import TypeUnary.Nat 21 | #ifdef UseTrees 22 | import Circat.RTree 23 | #else 24 | import TypeUnary.Vec hiding (transpose) 25 | #endif 26 | 27 | #ifdef UseTrees 28 | type V = Tree 29 | #else 30 | type V = Vec 31 | #endif 32 | -} 33 | 34 | infixl 7 <.> 35 | -- | Dot product, i.e., sum of products. 36 | (<.>) :: (Foldable f, Applicative f, Num a) => f a -> f a -> a 37 | u <.> v = sum (liftA2 (*) u v) 38 | {-# INLINE (<.>) #-} 39 | 40 | -- (<.>) :: (IsNat n, Num a) => V n a -> V n a -> a 41 | -- u <.> v = sum (u * v) 42 | 43 | -- -- | Linear map from a^m to a^n: Matrix with n rows and m columns 44 | -- type Lin m n a = V n (V m a) 45 | 46 | -- | Apply a linear map: dot each row of p with v 47 | -- apply :: (IsNat m, Num a) => Lin m n a -> V m a -> V n a 48 | apply :: (Foldable f, Applicative f, Num b, Functor g) => 49 | g (f b) -> f b -> g b 50 | apply p v = fmap (<.> v) p 51 | {-# INLINE apply #-} 52 | 53 | -- | Matrix transpose. Synonym for 'sequenceA' from Traversable. 54 | -- transpose :: IsNat m => Lin m n a -> Lin n m a 55 | transpose :: (Traversable g, Applicative f) => g (f a) -> f (g a) 56 | transpose = sequenceA 57 | 58 | infixr 9 @. 59 | -- | Compose linear transformations. 60 | -- p-transform each column of q to get columns of composition. 61 | -- (@.) :: (IsNat m, IsNat n, IsNat o, Num a) => 62 | -- Lin n o a -> Lin m n a -> Lin m o a 63 | (@.) :: ( Applicative h, Traversable g, Applicative g, Traversable f 64 | , Applicative f, Num a ) => 65 | h (g a) -> g (f a) -> h (f a) 66 | p @. q = transpose (fmap (apply p) (transpose q)) 67 | {-# INLINE (@.) #-} 68 | 69 | -- Efficiency note: all mappings and transpositions are compiled away. 70 | 71 | -- From TypeUnary.Vec, we get the Vec type, IsNat constraint, pointwise 72 | -- multiplication, and Traversable instance (used by transpose). 73 | -------------------------------------------------------------------------------- /src/LambdaCCC/Counters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 5 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 6 | 7 | ---------------------------------------------------------------------- 8 | -- | 9 | -- Module : LambdaCCC.Counters 10 | -- Copyright : (c) 2014 Tabula, Inc. 11 | -- 12 | -- Maintainer : conal@tabula.com 13 | -- Stability : experimental 14 | -- 15 | -- Up- and down-counters 16 | ---------------------------------------------------------------------- 17 | 18 | module LambdaCCC.Counters where 19 | 20 | -- TODO: explicit exports 21 | 22 | import Data.Functor ((<$>)) 23 | import Data.Traversable (Traversable) 24 | import Control.Applicative (Applicative(..),liftA2) 25 | 26 | import Circat.Misc (Unop) 27 | import Circat.Scan (LScan(..),lAlls,scanlT) 28 | import Circat.Circuit (GS) 29 | import Circat.Mealy 30 | 31 | toggleIf :: Bool -> Unop Bool 32 | toggleIf a = if a then not else id 33 | 34 | type Counter f = f Bool -> (f Bool, Bool) 35 | 36 | {-------------------------------------------------------------------- 37 | Linear versions 38 | --------------------------------------------------------------------} 39 | 40 | -- Increment/decrement a little-endian binary natural number: 41 | 42 | upL, downL :: (Applicative f, Traversable f) => Counter f 43 | 44 | upL bs = (liftA2 toggleIf alls bs, all') 45 | where 46 | (alls,all') = scanlT (&&) True bs 47 | 48 | downL bs = (liftA2 toggleIf alls bs, all') 49 | where 50 | (alls,all') = scanlT (&&) True (not <$> bs) 51 | 52 | -- Now make counters by iterating `upL` or 'downL' 53 | upCounterL, downCounterL :: (GS (f Bool), Applicative f, Traversable f) => 54 | Mealy () (f Bool) 55 | upCounterL = iterateU (fst . upL) (pure False) 56 | downCounterL = iterateU (fst . downL) (pure True ) 57 | 58 | {-------------------------------------------------------------------- 59 | Logarithmic versions 60 | --------------------------------------------------------------------} 61 | 62 | upF, downF :: (Applicative f, LScan f) => f Bool -> (f Bool, Bool) 63 | 64 | upF bs = (liftA2 toggleIf alls bs, all') 65 | where 66 | (alls,all') = lAlls bs 67 | 68 | downF bs = (liftA2 toggleIf alls bs, all') 69 | where 70 | (alls,all') = lAlls (not <$> bs) 71 | 72 | -- Now make counters by iterating `upF` or 'downF' 73 | upCounter, downCounter :: (GS (f Bool), Applicative f, LScan f) => 74 | Mealy () (f Bool) 75 | upCounter = iterateU (fst . upF) (pure False) 76 | downCounter = iterateU (fst . downF) (pure True ) 77 | -------------------------------------------------------------------------------- /src/LambdaCCC/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, MultiParamTypeClasses, CPP #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 5 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 6 | 7 | ---------------------------------------------------------------------- 8 | -- | 9 | -- Module : LambdaCCC.Misc 10 | -- Copyright : (c) 2013 Tabula, Inc. 11 | -- License : BSD3 12 | -- 13 | -- Maintainer : conal@tabula.com 14 | -- Stability : experimental 15 | -- 16 | -- Miscellany 17 | ---------------------------------------------------------------------- 18 | 19 | module LambdaCCC.Misc 20 | ( module Circat.Misc 21 | , Eq1'(..), (===?) 22 | ) where 23 | 24 | import Unsafe.Coerce (unsafeCoerce) -- see below 25 | 26 | import Data.Proof.EQ ((:=:)(..)) 27 | 28 | import Circat.Misc 29 | 30 | {-------------------------------------------------------------------- 31 | Transformations 32 | --------------------------------------------------------------------} 33 | 34 | #if 0 35 | 36 | -- | Unary transformation 37 | type Unop a = a -> a 38 | 39 | -- | Binary transformation 40 | type Binop a = a -> Unop a 41 | 42 | -- | Ternary transformation 43 | type Ternop a = a -> Binop a 44 | 45 | -- | Compose list of unary transformations 46 | compose :: [Unop a] -> Unop a 47 | compose = foldr (.) id 48 | 49 | #endif 50 | 51 | {-------------------------------------------------------------------- 52 | Types 53 | --------------------------------------------------------------------} 54 | 55 | #if 0 56 | 57 | infixr 1 :=> 58 | infixl 6 :+ 59 | infixl 7 :* 60 | 61 | TODO: Perhaps replace these definitions with a GADT to emphasize the 62 | distinction between standard Haskell unit, cartesian product, and function 63 | types, vs the categorical counterparts (terminal object, categorical 64 | products, and coproducts). 65 | 66 | type Unit = () 67 | type (:*) = (,) 68 | type (:+) = Either 69 | type (:=>) = (->) 70 | 71 | #endif 72 | 73 | {-------------------------------------------------------------------- 74 | Equality 75 | --------------------------------------------------------------------} 76 | 77 | -- | Equality when we don't know that the type parameters match. 78 | class Eq1' f where 79 | (====) :: f a -> f b -> Bool 80 | 81 | -- | Test for equality. If equal, generate a type equality proof. The proof 82 | -- generation is done with @unsafeCoerce@, so it's very important that equal 83 | -- terms really do have the same type. 84 | (===?) :: Eq1' f => f a -> f b -> Maybe (a :=: b) 85 | a ===? b | a ==== b = unsafeCoerce (Just Refl) 86 | | otherwise = Nothing 87 | 88 | -- TODO: Maybe eliminate Eq' and ==?. If so, rename (====) and (===?). 89 | -------------------------------------------------------------------------------- /src/LambdaCCC/ShowUtils.hs: -------------------------------------------------------------------------------- 1 | -- {-# LANGUAGE #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 5 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 6 | 7 | ---------------------------------------------------------------------- 8 | -- | 9 | -- Module : LambdaCCC.ShowUtils 10 | -- Copyright : (c) 2013 Tabula, Inc. 11 | -- License : BSD3 12 | -- 13 | -- Maintainer : conal@tabula.com 14 | -- Stability : experimental 15 | -- 16 | -- Helpers for implementing Show 17 | ---------------------------------------------------------------------- 18 | 19 | module LambdaCCC.ShowUtils 20 | ( showsApp1, showsApp, showSpaced 21 | , Prec, Assoc(..), Fixity 22 | , showsOp2, showsOp2', showsPair 23 | , module Circat.ShowUtils 24 | ) where 25 | 26 | import Data.List (intersperse) 27 | 28 | import Circat.ShowUtils 29 | 30 | import LambdaCCC.Misc (compose) 31 | 32 | {-------------------------------------------------------------------- 33 | Show helpers 34 | --------------------------------------------------------------------} 35 | 36 | -- | Show a simple function application 37 | showsApp1 :: Show a => String -> Prec -> a -> ShowS 38 | showsApp1 s p a = showParen (p > appPrec) $ 39 | showString s . showChar ' ' . showsPrec (appPrec+1) a 40 | 41 | -- | Show a simple function application 42 | showsApp :: (Show a, Show b) => Prec -> a -> b -> ShowS 43 | showsApp p a b = showParen (p > appPrec) $ 44 | showsPrec appPrec a . showChar ' ' . showsPrec (appPrec+1) b 45 | 46 | -- TODO: refactor showsApp1, showsApp 47 | 48 | -- Precedence of function application. 49 | -- Hack: use 11 instead of 10 to avoid extraneous parens when a function 50 | -- application is the left argument of a function composition. 51 | appPrec :: Int 52 | appPrec = 11 -- was 10 53 | 54 | -- TODO: Refactor showsApp & showsApp1 55 | -- TODO: Resolve argument order 56 | 57 | showSpaced :: [ShowS] -> ShowS 58 | showSpaced = compose . intersperse (showChar ' ') 59 | 60 | type Prec = Int 61 | data Assoc = AssocLeft | AssocRight | AssocNone 62 | type Fixity = (Prec,Assoc) 63 | 64 | showsOp2 :: (Show a, Show b) => 65 | Bool -> String -> Fixity -> Prec -> a -> b -> ShowS 66 | showsOp2 extraParens sop (p,assoc) q a b = 67 | showParen (q > p) $ 68 | showSpaced 69 | [ showsPrec (lf p) a 70 | , showString sop 71 | , showsPrec (rf p) b 72 | ] 73 | where 74 | (lf,rf) = case assoc of 75 | AssocLeft -> (incr, succ) 76 | AssocRight -> (succ, incr) 77 | AssocNone -> (succ, succ) 78 | incr | extraParens = succ 79 | | otherwise = id 80 | 81 | showsOp2' :: (Show a, Show b) => 82 | String -> Fixity -> Prec -> a -> b -> ShowS 83 | showsOp2' = showsOp2 False -- no extra parens 84 | 85 | -- parend :: ShowS -> Prec -> Prec -> ShowS 86 | -- parend sh p q = showParen (q > p) sh 87 | 88 | showsPair :: (Show a, Show b) => Prec -> a -> b -> ShowS 89 | showsPair _ a b = showParen True $ 90 | showsPrec 0 a . showChar ',' . showsPrec 0 b 91 | 92 | -- Simpler, but I don't like the resulting spaces around ",": 93 | -- 94 | -- showsPair = showsOp2 True "," (-1,AssocNone) 95 | -------------------------------------------------------------------------------- /src/LambdaCCC/OddEvenSort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, GADTs, ViewPatterns #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 5 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 6 | 7 | ---------------------------------------------------------------------- 8 | -- | 9 | -- Module : LambdaCCC.OddEvenSort 10 | -- Copyright : (c) 2014 Tabula, Inc. 11 | -- 12 | -- Maintainer : conal@tabula.com 13 | -- Stability : experimental 14 | -- 15 | -- Batcher's even-odd merge sort 16 | ---------------------------------------------------------------------- 17 | 18 | module LambdaCCC.OddEvenSort where 19 | 20 | -- TODO: explicit exports 21 | 22 | import Data.Functor ((<$>)) 23 | import Data.Foldable (toList) 24 | import Data.Traversable (Traversable) 25 | import Control.Arrow (first) 26 | 27 | import TypeUnary.TyNat (Z,S) 28 | import TypeUnary.TyNat (N1,N2,N3,N4) 29 | import TypeUnary.Nat (Nat(..),IsNat(..)) 30 | 31 | import Circat.Misc (Unop,transpose,inTranspose) 32 | import Circat.Pair (Pair(..),sortP) 33 | import Circat.RTree 34 | import Circat.Shift (shiftL,shiftR) 35 | 36 | msort :: (IsNat n, Ord a, Bounded a) => Unop (RTree n a) 37 | msort = msort' nat 38 | 39 | msort' :: (IsNat n, Ord a, Bounded a) => Nat n -> Unop (RTree n a) 40 | msort' Zero = id 41 | msort' (Succ m) = inB (merge . fmap (msort' m)) 42 | 43 | merge :: (Ord a, Bounded a) => Unop (Pair (RTree n a)) 44 | merge = undefined 45 | 46 | #if 0 47 | msort = msort' nat 48 | 49 | msort' :: (Ord a, Bounded a) => Nat n -> Unop (RTree n a) 50 | msort' Zero = id 51 | msort' (Succ m) = B . merge m . fmap (msort' m) . unB 52 | 53 | merge :: (Ord a, Bounded a) => Nat n -> Pair (LTree n a) -> LTree n (Pair a) 54 | merge Zero = \ (L a :# L b) -> L (sortP (a :# b)) 55 | 56 | merge (Succ m) = tweak . transpose . fmap (merge m) 57 | 58 | -- merge (Succ m) = inB (fmap sortP . (inTranspose.fmap) (merge m)) 59 | 60 | #if 0 61 | 62 | B :: 63 | 64 | transpose :: Pair (LTree (S m) a) -> LTree (S m) (Pair a) 65 | 66 | unB :: LTree (S m) a -> LTree m (Pair a) 67 | 68 | transpose :: LTree m (Pair a) -> Pair (LTree m a) 69 | 70 | fmap (merge m) :: Pair (LTree m a) -> Pair (LTree m a) 71 | transpose :: Pair (LTree m a) -> LTree m (Pair a) 72 | tweak :: LTree m (Pair a) -> LTree m (Pair a) 73 | 74 | B :: LTree m (Pair a) -> LTree (S m) a 75 | 76 | #endif 77 | 78 | -- Oops! I have to compare odd/even, not even/odd. 79 | 80 | tweak :: (Bounded a, Ord a) => Unop (LTree n (Pair a)) 81 | tweak ps = unB (fst (shiftL (bot,B (sortP <$> ps')))) 82 | where 83 | (bot,unB -> ps') = shiftR (B ps,maxBound) 84 | 85 | #if 0 86 | 87 | ps :: LTree n (Pair a) 88 | B ps :: LTree (S n) a 89 | (B ps, maxBound) :: (LTree (S n) a, a) 90 | shiftR (B ps, maxBound) :: (a, LTree (S n) a) 91 | bot :: a 92 | ps' :: LTree n (Pair a) 93 | sortP <$> ps' :: LTree n (Pair a) 94 | B (sortP <$> ps') :: LTree (S n) a 95 | (bot,B (sortP <$> ps')) :: (a,LTree (S n) a) 96 | fst (shiftL (bot,B (sortP <$> ps'))) :: LTree (S n) a 97 | unB (fst (shiftL (bot,B (sortP <$> ps')))) :: LTree n (Pair a) 98 | 99 | #endif 100 | 101 | #endif 102 | 103 | ps0 :: RTree N1 (Pair Int) 104 | ps0 = fromList [(1 :# 4),(3 :# 5)] 105 | 106 | -- tweak = fmap sortP 107 | 108 | {-------------------------------------------------------------------- 109 | Tests 110 | --------------------------------------------------------------------} 111 | 112 | test :: (IsNat n, Ord a, Bounded a) => RTree n a -> [a] 113 | test = toList . msort 114 | 115 | _t1 :: RTree N1 Int 116 | _t1 = tree1 4 3 117 | 118 | _t2 :: RTree N2 Int 119 | _t2 = tree2 4 3 1 5 120 | 121 | _t3 :: RTree N3 Int 122 | _t3 = tree3 4 3 7 1 9 5 2 6 123 | 124 | _t4 :: RTree N4 Int 125 | _t4 = tree4 4 12 3 16 8 11 15 7 1 10 9 14 5 13 2 6 126 | -------------------------------------------------------------------------------- /src/LambdaCCC/RadixSort.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-} 2 | {-# LANGUAGE ConstraintKinds #-} -- for LFScan 3 | {-# OPTIONS_GHC -Wall #-} 4 | 5 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 6 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 7 | 8 | ---------------------------------------------------------------------- 9 | -- | 10 | -- Module : LambdaCCC.RadixSort 11 | -- Copyright : (c) 2014 Tabula, Inc. 12 | -- 13 | -- Maintainer : conal@tabula.com 14 | -- Stability : experimental 15 | -- 16 | -- Parallel radix sort 17 | ---------------------------------------------------------------------- 18 | 19 | module LambdaCCC.RadixSort where 20 | 21 | -- TODO: explicit exports 22 | 23 | import Prelude hiding (sum) 24 | 25 | import Data.Foldable (Foldable,sum,toList) 26 | import Control.Applicative (Applicative(..),liftA2) 27 | import Control.Arrow ((***),first) 28 | 29 | import TypeUnary.Nat -- (IsNat(..)) 30 | import TypeUnary.Vec (Vec,vec1,(<+>)) 31 | 32 | import Circat.RTree 33 | import Circat.Scan (LScan(..),LFScan,lsums) 34 | 35 | type Bits n = Vec n Bool 36 | 37 | oneTree :: (IsNat n, Num b) => Bits n -> Tree n b 38 | oneTree v = update v (const 1) (pure 0) 39 | 40 | histogramStep :: (IsNat n, Num b) => 41 | RTree n b -> Bits n -> RTree n b 42 | histogramStep w v = w + oneTree v 43 | 44 | histogramFold :: (Foldable f, Functor f, IsNat n, Num b) => 45 | f (Bits n) -> RTree n b 46 | histogramFold = sum . fmap oneTree 47 | 48 | histogramScan :: (LFScan f, IsNat n, Num b) => 49 | f (Bits n) -> (f (RTree n b), RTree n b) 50 | histogramScan = lsums . fmap oneTree 51 | 52 | #if 0 53 | 54 | oneTree :: Bits n -> Tree n b 55 | fmap oneTree :: f (Bits n) -> f (Tree n b) 56 | lsums :: f (Tree n b) -> (f (Tree n b), b) 57 | 58 | #endif 59 | 60 | positions :: (Applicative f, LScan f, LScan (RTree n), IsNat n, Num b) => 61 | f (Bits n) -> f b 62 | positions vs = liftA2 combine partials vs 63 | where 64 | (partials,hist) = histogramScan vs 65 | (starts,_) = lsums hist 66 | combine partial v = (starts + partial) ! v 67 | 68 | #if 0 69 | 70 | vs :: f (Bits n) 71 | partials :: f (RTree n b) 72 | hist :: RTree n b 73 | starts :: RTree n b 74 | combine :: RTree n b -> Bits n -> b 75 | 76 | #endif 77 | 78 | #if 0 79 | -- Variation: (starts + partial) ! v --> (starts ! v) + (partial ! v). 80 | -- I get somewhat larger circuits. 81 | positions' :: (Applicative f, LScan f, LScan (RTree n), IsNat n, Num b) => 82 | f (Bits n) -> f b 83 | positions' vs = liftA2 combine partials vs 84 | where 85 | (partials,hist) = histogramScan vs 86 | (starts,_) = lsums hist 87 | combine partial v = (starts ! v) + (partial ! v) 88 | #endif 89 | 90 | -- TODO: Generalize to other tries 91 | 92 | {-------------------------------------------------------------------- 93 | Tests 94 | --------------------------------------------------------------------} 95 | 96 | -- Test histogramFold 97 | testHF :: (Functor f, Foldable f, IsNat n, Num b) => 98 | f (Bits n) -> [b] 99 | testHF = toList . histogramFold 100 | 101 | -- Test histogramScan 102 | testHS :: (LFScan f, Foldable f, IsNat n, Num b) => 103 | f (Bits n) -> ([[b]], [b]) 104 | testHS = first toList . (fmap toList *** toList) . histogramScan 105 | 106 | -- Test positions 107 | testPs :: (Foldable f, Applicative f, LScan f, LScan (RTree n), IsNat n, Num b) => 108 | f (Bits n) -> [b] 109 | testPs = toList . positions 110 | 111 | -- testSort vs = 112 | 113 | f,t :: Bits N1 114 | f = vec1 False 115 | t = vec1 True 116 | 117 | l1 :: [Bits N1] 118 | l1 = [t,f,f,t,f] 119 | 120 | t1 :: Tree N2 (Bits N1) 121 | t1 = tree2 t f f t 122 | 123 | -- > testHF l1 124 | -- [3,2] 125 | -- > testHF t1 126 | -- [2,2] 127 | -- > testHF l2 128 | -- [3,2,2,1] 129 | -- 130 | -- > testHS t1 131 | -- ([[0,0],[0,1],[1,1],[2,1]],[2,2]) 132 | -- 133 | -- > testPs t1 134 | -- [2,0,1,3] 135 | 136 | ff,ft,tf,tt :: Bits N2 137 | [ff,ft,tf,tt] = liftA2 (<+>) [f,t] [f,t] 138 | 139 | l2 :: [Bits N2] 140 | l2 = [tf,ft,ff,tt,tf,ff,ff,ft] 141 | 142 | t2 :: Tree N3 (Bits N2) 143 | t2 = tree3 tf ft ff tt tf ff ff ft 144 | 145 | -- > testHS t1 146 | -- ([[0,0],[0,1],[1,1],[2,1]],[2,2]) 147 | -- 148 | -- > testHS t2 149 | -- ([[0,0,0,0],[0,0,1,0],[0,1,1,0],[1,1,1,0],[1,1,1,1],[1,1,2,1],[2,1,2,1],[3,1,2,1]],[3,2,2,1]) 150 | -- 151 | -- > testPs t2 152 | -- [5,3,0,7,6,1,2,4] 153 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/TransCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 3 | {-# LANGUAGE ViewPatterns, PatternGuards #-} 4 | {-# LANGUAGE FlexibleContexts, ConstraintKinds #-} 5 | {-# LANGUAGE TupleSections #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# OPTIONS_GHC -Wall #-} 9 | 10 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 11 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 12 | 13 | ---------------------------------------------------------------------- 14 | -- | 15 | -- Module : LambdaCCC.TransCode 16 | -- Copyright : (c) 2014 Tabula, Inc. 17 | -- 18 | -- Maintainer : conal@tabula.com 19 | -- Stability : experimental 20 | -- 21 | -- Transform a Core program to use only standard types 22 | ---------------------------------------------------------------------- 23 | 24 | module LambdaCCC.TransCode where 25 | 26 | -- TODO: explicit exports 27 | 28 | import Prelude hiding (id,(.),(>>)) 29 | import qualified Prelude 30 | 31 | import Control.Category (id,(.),(>>>)) 32 | import Control.Arrow (arr) 33 | import Control.Monad (unless,(<=<)) 34 | import Data.Functor ((<$),(<$>)) 35 | import Control.Applicative (pure,(<*>),liftA2) 36 | import Data.Monoid (mempty) 37 | import Data.List (intercalate,isPrefixOf) 38 | import qualified Data.Set as S 39 | 40 | -- GHC 41 | import PrelNames (eitherTyConName) 42 | 43 | import HERMIT.Core (CoreDef(..)) 44 | import HERMIT.Dictionary hiding (externals) 45 | import HERMIT.External (External,ExternalName,external,(.+),CmdTag(Loop)) 46 | import HERMIT.GHC 47 | import HERMIT.Kure 48 | import HERMIT.Monad (saveDef,newIdH,Label) 49 | import HERMIT.Plugin (hermitPlugin,phase,interactive) 50 | 51 | import HERMIT.Extras hiding (findTyConT) 52 | import qualified HERMIT.Extras as Ex 53 | 54 | -- import TypeEncode.Plugin (findCon) 55 | 56 | import LambdaCCC.Misc ((<~)) 57 | 58 | import qualified LambdaCCC.Monomorphize as Mono 59 | 60 | {-------------------------------------------------------------------- 61 | Encoding 62 | --------------------------------------------------------------------} 63 | 64 | class Enc a where enc :: a -> TransformH x a 65 | 66 | instance (Enc a, Enc b) => Enc (a,b) where 67 | enc (a,b) = (,) <$> enc a <*> enc b 68 | instance Enc a => Enc [a] where enc = mapM enc 69 | 70 | instance Enc CoreExpr where 71 | enc e@(Lit _) = return e 72 | enc (Var v) = Var <$> enc v -- Revisit for non-local vars 73 | enc (App u v) = App <$> enc u <*> enc v 74 | enc (Lam x e) = Lam <$> enc x <*> enc e 75 | enc (Let b e) = Let <$> enc b <*> enc e 76 | enc (Case e _w _ty [(_,dropTvars -> [v],rhs)]) = 77 | -- TODO: Check whether _w is in rhs 78 | -- TODO: Maybe drop this special case. 79 | return $ Let (NonRec v e) rhs 80 | enc (Case e w ty [alt]) = 81 | Case <$> enc e 82 | <*> enc w 83 | <*> enc ty 84 | <*> ((:[]) <$> encAlt alt) 85 | enc (Case _ _ _ _) = error "enc: Case: not a single alternative" 86 | enc (Cast e _co) = enc e -- Experiment 87 | enc (Tick t e) = Tick t <$> enc e 88 | enc (Type t) = Type <$> enc t 89 | enc (Coercion _co) = error "enc: Coercion -- ??" 90 | 91 | encAlt :: CoreAlt -> TransformH x CoreAlt 92 | encAlt (_,dropTvars -> vs,e) = 93 | (DataAlt (tupleCon BoxedTuple (length vs)),vs,) <$> enc e 94 | 95 | -- Drop type variables including coercions 96 | dropTvars :: Unop [Var] 97 | dropTvars = filter (not . isTyVar) 98 | 99 | instance Enc Id where 100 | enc v | isId v = newIdT (uqVarName v) . enc (varType v) 101 | | otherwise = return v 102 | 103 | instance Enc Type where 104 | enc (TyConApp tc tys) | isDistribTC tc = TyConApp tc <$> enc tys 105 | enc (FunTy a b) = FunTy <$> enc a <*> enc b 106 | enc t = observeR "enc: unhandled type" $* t 107 | 108 | isDistribTC :: TyCon -> Bool 109 | isDistribTC tc = 110 | any ($ tc) [isTupleTyCon,isFunTyCon] && tyConArity tc == 2 111 | || tc == unitTyCon 112 | 113 | instance Enc CoreBind where 114 | enc (NonRec v e) = NonRec <$> enc v <*> enc e 115 | enc (Rec ws) = Rec <$> enc ws 116 | 117 | encode :: Enc a => RewriteH a 118 | encode = id >>= enc 119 | 120 | {-------------------------------------------------------------------- 121 | Plugin 122 | --------------------------------------------------------------------} 123 | 124 | plugin :: Plugin 125 | plugin = hermitPlugin (phase 0 . interactive externals) 126 | where 127 | externals = 128 | [ externC "encodeBind" (encode :: RewriteH CoreBind) "..." 129 | ] 130 | ++ Mono.externals 131 | -------------------------------------------------------------------------------- /src/LambdaCCC/StateTrie.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, TupleSections #-} 2 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 3 | 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | ---------------------------------------------------------------------- 7 | -- | 8 | -- Module : LambdaCCC.StateTrie 9 | -- Copyright : (c) 2014 Tabula, Inc. 10 | -- 11 | -- Maintainer : conal@tabula.com 12 | -- Stability : experimental 13 | -- 14 | -- Memoizing State monad 15 | ---------------------------------------------------------------------- 16 | 17 | module LambdaCCC.StateTrie 18 | ( StateTrieX, StateTrie(..) 19 | , toState, fromState 20 | , get, put, runStateTrie, evalStateTrie, execStateTrie 21 | ) where 22 | 23 | import Control.Arrow (first) 24 | import Control.Applicative (Applicative(..)) 25 | 26 | import Control.Monad.State -- mtl 27 | 28 | import Data.MemoTrie (HasTrie(..),(:->:)) 29 | 30 | import Circat.Rep (Rep,HasRep(..)) 31 | 32 | -- | 'StateTrie' inner representation 33 | type StateTrieX s a = s :->: (a,s) 34 | 35 | -- | Memoizing state monad 36 | newtype StateTrie s a = StateTrie { unStateTrie :: StateTrieX s a } 37 | 38 | -- | Operate inside a 'StateTrie'. 39 | inStateTrie :: (StateTrieX s a -> StateTrieX t b) 40 | -> (StateTrie s a -> StateTrie t b) 41 | inStateTrie = StateTrie <~ unStateTrie 42 | {-# INLINE inStateTrie #-} 43 | 44 | {- unused 45 | 46 | inStateTrie2 :: (StateTrieX s a -> StateTrieX t b -> StateTrieX u c) 47 | -> (StateTrie s a -> StateTrie t b -> StateTrie u c) 48 | inStateTrie2 = inStateTrie <~ unStateTrie 49 | 50 | -} 51 | 52 | -- | Run a memoized stateful computation 53 | runStateTrie :: HasTrie s => StateTrie s a -> s -> (a,s) 54 | runStateTrie (StateTrie t) = untrie t 55 | {-# INLINE runStateTrie #-} 56 | 57 | -- | Run a memoized stateful computation and return just value 58 | evalStateTrie :: HasTrie s => StateTrie s a -> s -> a 59 | evalStateTrie = (result.result) fst runStateTrie 60 | {-# INLINE evalStateTrie #-} 61 | 62 | -- | Run a memoized stateful computation and return just state 63 | execStateTrie :: HasTrie s => StateTrie s a -> s -> s 64 | execStateTrie = (result.result) snd runStateTrie 65 | {-# INLINE execStateTrie #-} 66 | 67 | instance HasTrie s => Functor (StateTrie s) where 68 | fmap = inStateTrie . fmap . first 69 | {-# INLINE fmap #-} 70 | 71 | instance HasTrie s => Applicative (StateTrie s) where 72 | pure a = StateTrie (trie (a,)) 73 | (<*>) = inState2 (<*>) 74 | {-# INLINE pure #-} 75 | {-# INLINE (<*>) #-} 76 | 77 | -- | 'State'-to-'StateTrie' adapter 78 | fromState :: HasTrie s => State s a -> StateTrie s a 79 | fromState = StateTrie . trie . runState 80 | {-# INLINE fromState #-} 81 | 82 | -- | 'StateTrie'-to-'State' adapter 83 | toState :: HasTrie s => StateTrie s a -> State s a 84 | toState = state . untrie . unStateTrie 85 | {-# INLINE toState #-} 86 | 87 | -- | Transform using 'State' view 88 | inState :: (HasTrie s, HasTrie t) => 89 | (State s a -> State t b) 90 | -> (StateTrie s a -> StateTrie t b) 91 | inState = fromState <~ toState 92 | {-# INLINE inState #-} 93 | 94 | -- | Transform using 'State' view 95 | inState2 :: (HasTrie s, HasTrie t, HasTrie u) => 96 | (State s a -> State t b -> State u c) 97 | -> (StateTrie s a -> StateTrie t b -> StateTrie u c) 98 | inState2 = inState <~ toState 99 | {-# INLINE inState2 #-} 100 | 101 | instance HasTrie s => Monad (StateTrie s) where 102 | return = pure 103 | m >>= f = joinST (fmap f m) 104 | {-# INLINE return #-} 105 | {-# INLINE (>>=) #-} 106 | 107 | joinST :: HasTrie s => StateTrie s (StateTrie s a) -> StateTrie s a 108 | joinST = fromState . join . fmap toState . toState 109 | {-# INLINE joinST #-} 110 | 111 | -- joinST = inState (join . fmap toState) 112 | -- = inState ((=<<) toState) 113 | 114 | instance HasTrie s => MonadState s (StateTrie s) where 115 | state = StateTrie . trie 116 | 117 | -- TODO: Perhaps use 'state' in the definitions of pure and fromState. 118 | 119 | type instance Rep (StateTrie s a) = StateTrieX s a 120 | instance HasRep (StateTrie s a) where 121 | repr (StateTrie t) = t 122 | abst = StateTrie 123 | 124 | 125 | {-------------------------------------------------------------------- 126 | Misc 127 | --------------------------------------------------------------------} 128 | 129 | -- | Add post- & pre-processing 130 | (<~) :: (b -> b') -> (a' -> a) -> ((a -> b) -> (a' -> b')) 131 | (h <~ f) g = h . g . f 132 | 133 | -- | Add post-processing 134 | result :: (b -> b') -> ((a -> b) -> (a -> b')) 135 | result = (.) 136 | -- result = (<~ id) 137 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/ToCircuit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GADTs, KindSignatures, ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts, PatternGuards, ViewPatterns, ScopedTypeVariables #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 7 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 8 | 9 | ---------------------------------------------------------------------- 10 | -- | 11 | -- Module : LambdaCCC.ToCircuit 12 | -- Copyright : (c) 2013 Tabula, Inc. 13 | -- LICENSE : BSD3 14 | -- 15 | -- Maintainer : conal@tabula.com 16 | -- Stability : experimental 17 | -- 18 | -- Convert from CCC form to a circuit 19 | ---------------------------------------------------------------------- 20 | 21 | module LambdaCCC.ToCircuit 22 | ( expToCircuit, cccToCircuit 23 | ) where 24 | 25 | import Prelude hiding (id,(.),curry,uncurry) 26 | import Data.Constraint (Dict(..)) 27 | 28 | import Circat.Prim hiding (xor) 29 | import LambdaCCC.CCC 30 | import LambdaCCC.Lambda (E) 31 | import LambdaCCC.ToCCC (toCCC) 32 | 33 | import Circat.Circuit 34 | import Circat.Category 35 | import Circat.Classes 36 | 37 | expToCircuit :: E Prim (a -> b) -> (a :> b) 38 | expToCircuit = cccToCircuit . toCCC 39 | 40 | #define TS (tyPSource -> Dict) 41 | #define CP (cccPS -> (Dict, Dict)) 42 | #define TC (tyHasCond -> Dict) 43 | 44 | #define LS (litSS -> Dict) 45 | 46 | cccToCircuit :: (a :-> b) -> (a :> b) 47 | 48 | -- Category 49 | cccToCircuit Id = id 50 | cccToCircuit (g :. f) = cccToCircuit g . cccToCircuit f 51 | -- Primitives 52 | cccToCircuit (Prim p) = primToSource p 53 | cccToCircuit (Lit l@LS) = constC (eval l) 54 | -- Product 55 | cccToCircuit Exl = exl 56 | cccToCircuit Exr = exr 57 | cccToCircuit (f :&&& g) = cccToCircuit f &&& cccToCircuit g 58 | -- Coproduct 59 | cccToCircuit Inl = inl 60 | cccToCircuit Inr = inr 61 | -- cccToCircuit k@(f :||| g) = cccToCircuit f |||* cccToCircuit g 62 | -- Exponential 63 | cccToCircuit Apply = apply 64 | cccToCircuit (Curry h) = curry (cccToCircuit h) 65 | cccToCircuit (Uncurry h) = uncurry (cccToCircuit h) 66 | 67 | cccToCircuit ccc = error $ "cccToCircuit: not yet handled: " ++ show ccc 68 | 69 | #define TH (tyHasTy -> HasTy) 70 | 71 | -- TODO: I don't know whether to keep add. We'll probably want to build it from 72 | -- simpler pieces. 73 | -- 74 | -- TODO: Maybe implement all primitives (other than exl & exr) with namedC. I 75 | -- could even use this PrimC type in circat, though it'd be the first dependency 76 | -- of circat on lambda-ccc. 77 | 78 | {-------------------------------------------------------------------- 79 | Prim conversion 80 | --------------------------------------------------------------------} 81 | 82 | primToSource :: Prim t -> Pins t 83 | primToSource NotP = not 84 | primToSource AndP = curry and 85 | primToSource OrP = curry or 86 | primToSource XorP = curry xor 87 | primToSource ExlP = exl 88 | primToSource ExrP = exr 89 | primToSource PairP = curry id 90 | primToSource InlP = inl 91 | primToSource InrP = inr 92 | -- primToSource CondP = condC 93 | -- primToSource AddP = curry (namedC "add") 94 | primToSource p = error $ "primToSource: not yet handled: " ++ show p 95 | 96 | #if 0 97 | 98 | -- Prove that IsSource (Pins a), IsSource (Pins b) 99 | cccPS :: (a :-> b) -> (PSourceJt a, PSourceJt b) 100 | cccPS = tyPSource2 . cccTys 101 | 102 | {-------------------------------------------------------------------- 103 | Proofs 104 | --------------------------------------------------------------------} 105 | 106 | type PSourceJt a = Dict (IsSourceP a) 107 | 108 | -- | Proof of @'IsSource' ('Pins' a)@ from @'Ty' a@ 109 | tyPSource :: Ty a -> PSourceJt a 110 | tyPSource Unit = Dict 111 | tyPSource Bool = Dict 112 | tyPSource (TS :* TS) = Dict -- still needed? 113 | tyPSource ty = error $ "tyPSource: Oops -- not yet handling " ++ show ty 114 | 115 | -- That product case gets used for my CRC example when I turn off the 116 | -- xor/constant rewrite rules. 117 | 118 | tyPSource2 :: (Ty a,Ty b) -> (PSourceJt a, PSourceJt b) 119 | tyPSource2 (a,b) = (tyPSource a,tyPSource b) 120 | 121 | -- tyPSource2 = tyPSource *** tyPSource 122 | 123 | -- | Proof of @'HasCond t@ from @'Ty' t@ 124 | tyHasCond :: Ty t -> Dict (HasCond t) 125 | tyHasCond Unit = Dict 126 | tyHasCond Bool = Dict 127 | tyHasCond (TC :* TC) = Dict 128 | tyHasCond (_ :+ _ ) = Dict 129 | tyHasCond (_ :=> TC) = Dict 130 | tyHasCond Int = error "tyHasCond: Int not yet handled." 131 | 132 | #endif -------------------------------------------------------------------------------- /src/LambdaCCC/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeOperators, ExistentialQuantification, FlexibleContexts #-} 3 | {-# LANGUAGE ConstraintKinds, StandaloneDeriving #-} 4 | -- Okay 5 | {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} 6 | 7 | {-# OPTIONS_GHC -Wall #-} 8 | 9 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 10 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 11 | 12 | #define MealyAsFun 13 | 14 | ---------------------------------------------------------------------- 15 | -- | 16 | -- Module : Run 17 | -- Copyright : (c) 2014 Tabula, Inc. 18 | -- 19 | -- Maintainer : conal@tabula.com 20 | -- Stability : experimental 21 | -- 22 | -- Run a test: reify, CCC, circuit 23 | ---------------------------------------------------------------------- 24 | 25 | module LambdaCCC.Run 26 | ( go,go',goSep,run,goM,goM',goMSep 27 | , goNew, goNew' 28 | ) where 29 | 30 | import Prelude 31 | 32 | import LambdaCCC.Lambda (EP,reifyEP) 33 | import LambdaCCC.ToCCC (toCCC) 34 | 35 | import Circat.Category (Uncurriable) 36 | import Circat.Circuit (Attr,mkGraph,UU,outDotG,unitize',(:>)) 37 | 38 | import Circat.Netlist (saveAsVerilog) 39 | import Circat.Mealy (Mealy(..)) 40 | 41 | #if defined MealyAsFun 42 | import Circat.Mealy (asFun) 43 | #else 44 | import Circat.Circuit (MealyC(..),unitizeMealyC) 45 | import Control.Arrow (first) 46 | #endif 47 | 48 | ranksep :: Double -> Attr 49 | ranksep n = ("ranksep",show n) 50 | 51 | type Okay = Uncurriable (:>) () 52 | 53 | go' :: Okay a => String -> [Attr] -> a -> IO () 54 | #if defined MealyAsFun 55 | go' = goNew' -- Tidy up later 56 | #else 57 | go' name attrs f = goM' name attrs (Mealy (first f) ()) 58 | #endif 59 | {-# INLINE go' #-} 60 | 61 | go :: Okay a => String -> a -> IO () 62 | go name = go' name [] 63 | {-# INLINE go #-} 64 | 65 | goSep :: Okay a => String -> Double -> a -> IO () 66 | goSep name s = go' name [ranksep s] 67 | 68 | -- Run an example: reify, CCC, circuit. 69 | run :: Okay a => String -> [Attr] -> EP a -> IO () 70 | run name attrs e = do print e 71 | outGV name attrs (unitize' (toCCC e)) 72 | {-# NOINLINE run #-} 73 | 74 | goNew' :: Okay a => String -> [Attr] -> a -> IO () 75 | goNew' name attrs f = run name attrs (reifyEP f) 76 | {-# INLINE goNew' #-} 77 | 78 | goNew :: Okay a => String -> a -> IO () 79 | goNew name = goNew' name [] 80 | {-# INLINE goNew #-} 81 | 82 | -- Diagram and Verilog 83 | outGV :: String -> [Attr] -> UU -> IO () 84 | outGV name attrs circ = 85 | do outD ("pdf","") 86 | -- outD ("svg","") 87 | -- outD ("png","-Gdpi=200") 88 | outV 89 | where 90 | g = mkGraph name circ 91 | outD ss = outDotG ss attrs g 92 | outV = saveAsVerilog g 93 | {-# NOINLINE outGV #-} 94 | 95 | -- TODO: Move file-saving code from outD and saveVerilog to here. 96 | 97 | {-------------------------------------------------------------------- 98 | State machines 99 | --------------------------------------------------------------------} 100 | 101 | goM :: Okay (a -> b) => String -> Mealy a b -> IO () 102 | goM name = goM' name [] 103 | {-# INLINE goM #-} 104 | 105 | goMSep :: Okay (a -> b) => String -> Double -> Mealy a b -> IO () 106 | goMSep name s = goM' name [ranksep s] 107 | {-# INLINE goMSep #-} 108 | 109 | goM' :: Okay (a -> b) => String -> [Attr] -> Mealy a b -> IO () 110 | {-# INLINE goM' #-} 111 | 112 | #if defined MealyAsFun 113 | goM' name attrs = go' name attrs . asFun 114 | #else 115 | 116 | goM' name attrs m = putStrLn ("Compiling " ++ name) >> 117 | runM name attrs (reifyMealy m) 118 | 119 | -- Reified Mealy machine 120 | data MealyE a b = 121 | forall s. (GenBuses s, Show s) => MealyE (EP ((a,s) -> (b,s))) s 122 | 123 | -- The Show constraint is just for the following Show, which is handy for debugging. 124 | -- (See the 'print' in toMealyC.) 125 | deriving instance Show (MealyE a b) 126 | 127 | reifyMealy :: Mealy a b -> MealyE a b 128 | reifyMealy (Mealy f s) = MealyE (reifyEP f) s 129 | {-# INLINE reifyMealy #-} 130 | 131 | toMealyC :: MealyE a b -> MealyC a b 132 | toMealyC (MealyE f s) = MealyC (toCCC' f) s 133 | 134 | runM :: Okay a => String -> [Attr] -> MealyE a b -> IO () 135 | runM name attrs e = do print e 136 | outGV name attrs (unitizeMealyC (toMealyC e)) 137 | 138 | -- TODO: When mealyAsArrow works, rewrite goM' via go' instead of vice versa 139 | 140 | -- Despite INLINE pragmas, I still have to explicitly tell HERMIT to unfold 141 | -- definitions from this module: 142 | -- 143 | -- try (any-td (unfold ['go,'go','goM,'goM','reifyMealy])) 144 | 145 | -- TODO: Maybe pull unitizeMealyC into toMealyC, renaming to "toMealyU" 146 | 147 | #endif 148 | 149 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/Encode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators #-} 2 | {-# LANGUAGE FlexibleInstances, FlexibleContexts #-} 3 | {-# LANGUAGE UndecidableInstances #-} -- See below 4 | {-# LANGUAGE CPP #-} 5 | 6 | {-# OPTIONS_GHC -Wall #-} 7 | 8 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 9 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 10 | 11 | ---------------------------------------------------------------------- 12 | -- | 13 | -- Module : LambdaCCC.Encode 14 | -- Copyright : (c) 2013 Tabula, Inc. 15 | -- License : BSD3 16 | -- 17 | -- Maintainer : conal@tabula.com 18 | -- Stability : experimental 19 | -- 20 | -- Statically typed lambda expressions 21 | ---------------------------------------------------------------------- 22 | 23 | -- #define VecsAndTrees 24 | 25 | module LambdaCCC.Encode (Encodable(..),(-->),recode) where 26 | 27 | import Control.Arrow ((+++)) -- ,(***) 28 | import Data.Monoid (Any(..),All(..)) 29 | 30 | -- transformers 31 | import Data.Functor.Identity 32 | 33 | #ifdef VecsAndTrees 34 | import TypeUnary.TyNat (Z,S) 35 | import TypeUnary.Nat (Nat(..),IsNat(..)) 36 | import TypeUnary.Vec (Vec(..),unConsV) 37 | import Circat.Pair (Pair(..),toP,fromP) 38 | import Circat.RTree (Tree(..),toL,unL,toB,unB) 39 | #endif 40 | 41 | import LambdaCCC.Misc (Unit,(:+),(:*)) 42 | 43 | infixr 1 --> 44 | -- | Add pre- and post processing 45 | (-->) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b')) 46 | (f --> h) g = h . g . f 47 | 48 | -- (-->) :: Category k => 49 | -- (a' `k` a) -> (b `k` b') -> ((a `k` b) -> (a' `k` b')) 50 | 51 | -- Slightly different from Arrow.***. No lazy pattern. 52 | -- Makes neater code. 53 | infixr 3 *** 54 | (***) :: (a -> c) -> (b -> d) -> (a :* b -> c :* d) 55 | (f *** g) (x,y) = (f x, g y) 56 | 57 | -- Inlining! 58 | #define INS {-# INLINE encode #-} ; {-# INLINE decode #-} 59 | 60 | -- | Encoding and decoding. Must be inverses, and @'Encode' a@ must have a 61 | -- standard type. A type is standard iff it is '()', 'Bool', 'Int' (for now), or 62 | -- a binary product, sum, or function over standard types. 63 | class Encodable a where 64 | type Encode a 65 | encode :: a -> Encode a 66 | decode :: Encode a -> a 67 | 68 | #define EncTy(n,o) type Encode (n) = o ; INS 69 | 70 | instance (Encodable a, Encodable b) => Encodable (a :* b) where 71 | -- EncTy(a :* b, Encode a :* Encode b) 72 | EncTy((a,b), (Encode a,Encode b)) 73 | encode = encode *** encode 74 | decode = decode *** decode 75 | 76 | instance (Encodable a, Encodable b) => Encodable (a :+ b) where 77 | EncTy(a :+ b, Encode a :+ Encode b) 78 | encode = encode +++ encode 79 | decode = decode +++ decode 80 | 81 | instance (Encodable a, Encodable b) => Encodable (a -> b) where 82 | EncTy(a -> b, Encode a -> Encode b) 83 | encode = decode --> encode 84 | decode = encode --> decode 85 | 86 | #define PrimEncode(t) \ 87 | instance Encodable (t) where { EncTy(t,t) ; encode = id ; decode = id } 88 | 89 | PrimEncode(Unit) 90 | PrimEncode(Bool) 91 | PrimEncode(Int) 92 | 93 | -- instance Encodable Bool where 94 | -- EncTy(Bool,() :+ ()) 95 | -- encode False = Left () 96 | -- encode True = Right () 97 | -- decode (Left ()) = False 98 | -- decode (Right ()) = True 99 | 100 | {-------------------------------------------------------------------- 101 | Library types 102 | --------------------------------------------------------------------} 103 | 104 | #define EEncTy(n,o) EncTy(n,Encode(o)) 105 | 106 | #define RepEncode(n,o,unwrap,wrap) \ 107 | instance Encodable (o) => Encodable (n) where \ 108 | { EEncTy(n,o) ; encode = encode . (unwrap) ; decode = (wrap) . decode } 109 | 110 | -- TODO: Can we get some help from the Newtype class? 111 | 112 | #ifdef VecsAndTrees 113 | 114 | RepEncode(Nat Z, (), \ Zero -> (), \ () -> Zero) 115 | -- RepEncode(Nat (S n), Nat n, predN, Succ) 116 | 117 | instance IsNat n => Encodable (Nat (S n)) where 118 | EEncTy (Nat (S n),()) 119 | encode = const () 120 | decode = const nat 121 | 122 | -- instance (IsNat n, Encodable (Nat n)) => Encodable (Nat (S n)) where 123 | -- EEncTy (Nat (S n),Nat n) 124 | -- encode (Succ m) = encode m 125 | -- decode x = Succ (decode x) 126 | 127 | RepEncode(Pair a, a :* a, fromP, toP) 128 | 129 | RepEncode(Vec Z a, (), \ ZVec -> (), \ () -> ZVec) 130 | RepEncode(Vec (S n) a, a :* Vec n a, unConsV, (\ (a,b) -> a :< b)) 131 | -- RepEncode(Vec (S n) a, a :* Vec n a, unConsV, uncurry (:<)) 132 | -- The non-lazy pattern match gives tighter code than uncurry 133 | RepEncode(Tree Z a, a, unL, toL) 134 | RepEncode(Tree (S n) a, Pair (Tree n a), unB, toB) 135 | 136 | #endif 137 | 138 | -- Standard newtypes: 139 | RepEncode(Any,Bool,getAny,Any) 140 | RepEncode(All,Bool,getAll,All) 141 | -- etc 142 | 143 | -- Application is no smaller than the instance head 144 | -- in the type family application: Encode Bool 145 | -- (Use UndecidableInstances to permit this) 146 | -- In the type instance declaration for ‘Encode’ 147 | -- In the instance declaration for ‘Encodable (Any)’ 148 | 149 | RepEncode(Identity a, a, runIdentity, Identity) 150 | 151 | -- | Identity via 'encode' and decode. 152 | recode :: Encodable a => a -> a 153 | recode = decode . encode 154 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/Ty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GADTs, KindSignatures, TypeSynonymInstances #-} 2 | {-# LANGUAGE PatternGuards, ConstraintKinds #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 7 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 8 | 9 | ---------------------------------------------------------------------- 10 | -- | 11 | -- Module : LambdaCCC.Ty 12 | -- Copyright : (c) 2013 Tabula, Inc. 13 | -- License : BSD3 14 | -- 15 | -- Maintainer : conal@tabula.com 16 | -- Stability : experimental 17 | -- 18 | -- Typed types 19 | ---------------------------------------------------------------------- 20 | 21 | module LambdaCCC.Ty 22 | ( Ty(..),HasTy(..), tyEq', tyEq2' 23 | , HasTy2,HasTy3,HasTy4 24 | , HasTyJt(..), tyHasTy, tyHasTy2 25 | , pairTyHasTy, sumTyHasTy, funTyHasTy 26 | , splitFunTy, domTy, ranTy 27 | ) where 28 | 29 | import Control.Applicative (liftA2) 30 | 31 | import Data.IsTy 32 | import Data.Proof.EQ 33 | 34 | import LambdaCCC.Misc 35 | import LambdaCCC.ShowUtils 36 | 37 | infixr 1 :=> 38 | infixl 6 :+ 39 | infixl 7 :* 40 | 41 | -- | Typed type representation 42 | data Ty :: * -> * where 43 | Unit :: Ty Unit 44 | Int :: Ty Int 45 | Bool :: Ty Bool 46 | (:*) :: Ty a -> Ty b -> Ty (a :* b) 47 | (:+) :: Ty a -> Ty b -> Ty (a :+ b) 48 | (:=>) :: Ty a -> Ty b -> Ty (a :=> b) 49 | 50 | instance Show (Ty a) where 51 | showsPrec _ Unit = showString "Unit" 52 | showsPrec _ Int = showString "Int" 53 | showsPrec _ Bool = showString "Bool" 54 | showsPrec p (a :* b) = showsOp2' ":*" (7,AssocLeft ) p a b 55 | showsPrec p (a :+ b) = showsOp2' ":+" (6,AssocLeft ) p a b 56 | showsPrec p (a :=> b) = showsOp2' ":=>" (1,AssocRight) p a b 57 | 58 | instance IsTy Ty where 59 | Unit `tyEq` Unit = Just Refl 60 | Int `tyEq` Int = Just Refl 61 | Bool `tyEq` Bool = Just Refl 62 | (a :* b) `tyEq` (a' :* b') = tyEqOp2 a b a' b' 63 | (a :+ b) `tyEq` (a' :+ b') = tyEqOp2 a b a' b' 64 | (a :=> b) `tyEq` (a' :=> b') = tyEqOp2 a b a' b' 65 | _ `tyEq` _ = Nothing 66 | 67 | tyEqOp2 :: Ty a -> Ty b -> Ty a' -> Ty b' -> Maybe (op a b :=: op a' b') 68 | tyEqOp2 a b a' b' = liftA2 liftEq2 (a `tyEq` a') (b `tyEq` b') 69 | 70 | -- Inferred type: 71 | -- 72 | -- (IsTyConstraint f1 a, IsTyConstraint f1 a', IsTyConstraint f2 b, 73 | -- IsTyConstraint f2 b', IsTy f1, IsTy f2) => 74 | -- f1 a -> f1 a' -> f2 b -> f2 b' -> Maybe (f a b :=: f a' b') 75 | 76 | -- | Variant of 'tyEq' from the 'ty' package. This one assumes 'HasTy'. 77 | tyEq' :: forall a b f. (HasTy a, HasTy b, Eq (f a)) => 78 | f a -> f b -> Maybe (a :=: b) 79 | fa `tyEq'` fb 80 | | Just Refl <- (typ :: Ty a) `tyEq` (typ :: Ty b) 81 | , fa == fb = Just Refl 82 | | otherwise = Nothing 83 | 84 | -- | Variant of 'tyEq' from the 'ty' package. This one assumes 'HasTy'. 85 | tyEq2' :: forall a b c d f. (HasTy a, HasTy b, HasTy c, HasTy d, Eq (f a b)) => 86 | f a b -> f c d -> Maybe ((a,b) :=: (c,d)) 87 | fab `tyEq2'` fcd 88 | | Just Refl <- (typ :: Ty a) `tyEq` (typ :: Ty c) 89 | , Just Refl <- (typ :: Ty b) `tyEq` (typ :: Ty d) 90 | , fab == fcd = Just Refl 91 | | otherwise = Nothing 92 | 93 | {-------------------------------------------------------------------- 94 | Type synthesis 95 | --------------------------------------------------------------------} 96 | 97 | -- TODO: Try out the singletons library 98 | 99 | -- | Synthesize a type 100 | class HasTy a where typ :: Ty a 101 | 102 | type HasTy2 a b = (HasTy a, HasTy b) 103 | type HasTy3 a b c = (HasTy2 a b, HasTy c) 104 | type HasTy4 a b c d = (HasTy3 a b c, HasTy d) 105 | 106 | instance HasTy Unit where typ = Unit 107 | instance HasTy Int where typ = Int 108 | instance HasTy Bool where typ = Bool 109 | instance HasTy2 a b => HasTy (a :* b) where typ = typ :* typ 110 | instance HasTy2 a b => HasTy (a :+ b) where typ = typ :+ typ 111 | instance HasTy2 a b => HasTy (a :=> b) where typ = typ :=> typ 112 | 113 | {-------------------------------------------------------------------- 114 | Proofs 115 | --------------------------------------------------------------------} 116 | 117 | -- | Judgment (proof) that 'HasTy' 118 | data HasTyJt :: * -> * where 119 | HasTy :: HasTy a => HasTyJt a 120 | 121 | -- TODO: Consider a generic replacement for types like this one. Try the generic 122 | -- Dict type from Edward K's "constraints" package. Replace HasTyJt a with 123 | -- Dict (HasTy a). 124 | 125 | -- | Proof of @'HasTy' a@ from @'Ty' a@ 126 | tyHasTy :: Ty a -> HasTyJt a 127 | tyHasTy Unit = HasTy 128 | tyHasTy Int = HasTy 129 | tyHasTy Bool = HasTy 130 | tyHasTy (a :* b) | (HasTy,HasTy) <- tyHasTy2 a b = HasTy 131 | tyHasTy (a :+ b) | (HasTy,HasTy) <- tyHasTy2 a b = HasTy 132 | tyHasTy (a :=> b) | (HasTy,HasTy) <- tyHasTy2 a b = HasTy 133 | 134 | tyHasTy2 :: Ty a -> Ty b -> (HasTyJt a,HasTyJt b) 135 | tyHasTy2 a b = (tyHasTy a,tyHasTy b) 136 | 137 | pairTyHasTy :: Ty (a :* b) -> (HasTyJt a,HasTyJt b) 138 | pairTyHasTy (a :* b) = tyHasTy2 a b 139 | 140 | sumTyHasTy :: Ty (a :+ b) -> (HasTyJt a,HasTyJt b) 141 | sumTyHasTy (a :+ b) = tyHasTy2 a b 142 | 143 | funTyHasTy :: Ty (a :=> b) -> (HasTyJt a,HasTyJt b) 144 | funTyHasTy (a :=> b) = tyHasTy2 a b 145 | 146 | 147 | {-------------------------------------------------------------------- 148 | Utilities 149 | --------------------------------------------------------------------} 150 | 151 | splitFunTy :: Ty (a -> b) -> (Ty a, Ty b) 152 | splitFunTy (a :=> b) = (a,b) 153 | 154 | domTy :: Ty (a -> b) -> Ty a 155 | domTy = fst . splitFunTy 156 | 157 | ranTy :: Ty (a -> b) -> Ty b 158 | ranTy = snd . splitFunTy 159 | -------------------------------------------------------------------------------- /doc/notes.md: -------------------------------------------------------------------------------- 1 | # Miscellaneous project notes 2 | 3 | [*From Haskell to hardware via cartesian closed categories*]: http://conal.net/blog/posts/haskell-to-hardware-via-cccs/ "blog post" 4 | 5 | [*Overloading lambda*]: http://conal.net/blog/posts/overloading-lambda "blog post" 6 | 7 | [*Optimizing CCCs*]: http://conal.net/blog/posts/optimizing-cccs "blog post" 8 | 9 | [*Circuits as a bicartesian closed category*]: http://conal.net/blog/posts/circuits-as-a-bicartesian-closed-category "blog post" 10 | 11 | [HERMIT]: http://www.ittc.ku.edu/csdl/fpg/software/hermit.html "project description" 12 | 13 | [KURE]: http://www.ittc.ku.edu/csdl/fpg/software/kure.html "project description" 14 | 15 | [circat]: https://github.com/conal/circat "Github repo" 16 | 17 | [type-encode]: https://github.com/conal/type-encode "Github repo" 18 | 19 | [`LambdaCCC.Lambda`]: ../src/LambdaCCC/Lambda.hs 20 | 21 | [`LambdaCCC.ToCCC`]: ../src/LambdaCCC/ToCCC.hs 22 | 23 | [`LambdaCCC.Reify`]: ../src/LambdaCCC/Reify.hs 24 | 25 | [*System F with Type Equality Coercions* (expanded version)]: https://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/tldi22-sulzmann-with-appendix.pdf "paper by Martin Sulzmann, Manuel Chakravarty, and Simon Peyton Jones" 26 | 27 | ## Overview 28 | 29 | This project explores a means of compiling Haskell programs in non-traditional ways. 30 | The original motivation (and Conal's main focus) is compilation of Haskell to massively parallel, reconfigurable hardware (FPGAs and the like). 31 | 32 | The overall flow: 33 | 34 | * GHC compiles Haskell source code to Core. 35 | * A [HERMIT]-based plugin ([`LambdaCCC.Reify`]) transforms the Core into other Core that *reifies* the original, i.e., constructs a representation of that Core designed for convenient manipulation (interpretation, translation, etc) by Haskell programs. 36 | * Unlike Core, this new representation is a *generalized* algebraic data type (GADT) (in [`LambdaCCC.Lambda`]), which means that programs manipulating it are easier to write (not having to insert type representations explicitly), with typing bugs caught early. 37 | (A type-correct Haskell program can construct type-incorrect Core.) 38 | * *Issue:* How much expressiveness do we lose? 39 | * *Issue:* What to call this GADT representation in our documents and conversations? 40 | * The expression GADT is converted (in [`LambdaCCC.ToCCC`]) to a vocabulary of bicartesian closed categories (biCCCs). 41 | To get a particular interpretation, simply type-specialize the result of this conversion to a particular biCCC. 42 | The biCCC vocabulary is much like `Category` (in [`Control.Category`](http://hackage.haskell.org/package/base/docs/Control-Category.html)), and `Arrow`, `ArrowChoice`, and `ArrowApply` (in [`Control.Arrow`](http://hackage.haskell.org/package/base/docs/Control-Arrow.html)). 43 | * One such biCCC is "circuit generators", as implemented in the [circat] project. 44 | That project also produces circuit drawings (via graphviz) and Verilog generation. 45 | 46 | There are a few blog posts about the motivation and technical directions: 47 | 48 | * [*From Haskell to hardware via cartesian closed categories*] 49 | * [*Overloading lambda*] 50 | * [*Optimizing CCCs*] 51 | * [*Circuits as a bicartesian closed category*] 52 | 53 | 54 | ## To do 55 | 56 | Procedural: 57 | 58 | * Make GitHub issues for each of these to-do items, and either link to them here or eliminate this list. 59 | 60 | Documentation: 61 | 62 | * Haddock: 63 | * Write module overviews 64 | * Fill in missing documentation for exports. 65 | 66 | Design & implementation: 67 | 68 | * Finish separation of lambda expressions from the underlying primitives. 69 | There's a good start already, as the expression `E` (in [`LambdaCCC.Lambda`]) and the [conversion to biCCCs][`LambdaCCC.ToCCC`] are parametrized over a type constructor of primitives. 70 | The [reification plugin][`LambdaCCC.Reify`], however, doesn't yet know about this parametrization and so can only handle the primitives designed for [circat]. 71 | *[Issue #4](https://github.com/conal/lambda-ccc/issues/4)* 72 | * Handle record field accessors, including type class methods. 73 | *[Issue #5](https://github.com/conal/lambda-ccc/issues/5)* 74 | * Do something sensible with unboxed types, even if just avoiding them. 75 | For instance, an `Int` literal `1` gets reified as `appP (reifyEP I#) (reifyEP 1)`. 76 | With types shown, this sub-expression `(reifyEP 1)` becomes `(reifyEP @ Int# 1)` which is not well-kinded. 77 | (Similarly for the other `reifyEP` call.) 78 | I think an easy fix would be having `reifyOf` in [`Lambda.Reify`] only apply if the argument type has kind `*`. 79 | *[Issue #6](https://github.com/conal/lambda-ccc/issues/6)* 80 | * Coercions and casts 81 | *[Issue #7](https://github.com/conal/lambda-ccc/issues/7)* 82 | * Handle them in the representation and translation. 83 | * Check handling of `newtype`s, which are represented via a coercion. 84 | * Type-encoding, in which algebraic data types (LDTs) are converted to binary sums and products. 85 | (Sorry for the odd acronym. I like "ADT" to mean "abstract data type".) 86 | See the [type-encode] project. 87 | Conversion is working well for *regular* LDTs. 88 | * Extend to GADTs. 89 | My understanding of [*System F with Type Equality Coercions* (expanded version)] is that GADTs are represented as regular LDTs, plus some type-level proofs. 90 | I'm hopeful that handling them will be fairly straightforward, fitting those type-level proofs into the reified representation (still at the type level). 91 | We'll see. 92 | * Tie into [circat], interpreting the `encode` and `decode` conversions. 93 | * I think we'll want to synthesize `Encodable` dictionaries in the plugin, which is not yet easy in HERMIT. 94 | 95 | 96 | ## Contributors 97 | 98 | * Conal Elliott: concept, design, implementation 99 | * Andy Gill: many helpful conversations about the project; exploring additional applications 100 | * Andrew Farmer: consulting on KURE & HERMIT 101 | * Neil Sculthorpe: consulting on KURE & HERMIT 102 | * Nicolas Frisby: consulting on KURE & HERMIT 103 | * Tabula: support for Conal's work on the project 104 | * Steve Teig (Tabula's founder, president, CTO): originally suggested the Haskell-to-hardware project; numerous technical conversations. 105 | 106 | Please let me know if I've forgotten to mention you! 107 | -------------------------------------------------------------------------------- /src/LambdaCCC/ToCCC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GADTs, PatternGuards, ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} 3 | {-# LANGUAGE ConstraintKinds, RankNTypes, CPP #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 8 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 9 | 10 | ---------------------------------------------------------------------- 11 | -- | 12 | -- Module : LambdaCCC.ToCCC 13 | -- Copyright : (c) 2013 Tabula, Inc. 14 | -- License : BSD3 15 | -- 16 | -- Maintainer : conal@tabula.com 17 | -- Stability : experimental 18 | -- 19 | -- Convert lambda expressions to CCC combinators 20 | ---------------------------------------------------------------------- 21 | 22 | #define PlainConvert 23 | 24 | module LambdaCCC.ToCCC 25 | ( toCCC, toCCC' 26 | #ifndef PlainConvert 27 | , HasLambda(..) 28 | #endif 29 | ) where 30 | 31 | import Prelude hiding (id,(.),curry,uncurry,const) 32 | 33 | import Data.Functor ((<$>)) 34 | import Control.Monad (mplus) 35 | import Data.Maybe (fromMaybe) 36 | -- import Data.Coerce (Coercible,coerce) 37 | 38 | import Data.Proof.EQ 39 | 40 | import LambdaCCC.Misc 41 | import LambdaCCC.Lambda (E(..),V,Pat(..)) 42 | import Circat.Category 43 | 44 | -- Sad hack. I don't yet know how to handle Loop generally enough. 45 | -- See BiCCCC'. 46 | -- TODO: rethink the whole extensibility thing. 47 | import Circat.Circuit ((:>)) 48 | import Circat.Prim (Prim) 49 | 50 | {-------------------------------------------------------------------- 51 | Conversion 52 | --------------------------------------------------------------------} 53 | 54 | #ifdef PlainConvert 55 | 56 | -- type BiCCCC' k p = BiCCCC k p 57 | -- Sad hack. See above. 58 | type BiCCCC' k p = (k ~ (:>), p ~ Prim) 59 | 60 | -- | Rewrite a lambda expression via CCC combinators 61 | toCCC :: BiCCCC' k p => E p a -> (Unit `k` a) 62 | toCCC e = convert e UnitPat 63 | 64 | -- toCCC :: forall p a. E p a -> forall k. BiCCCC' k p => (Unit `k` a) 65 | 66 | -- | Convert @\ p -> e@ to CCC combinators 67 | convert :: forall a b prim k. BiCCCC' k prim => 68 | E prim b -> Pat a -> (a `k` b) 69 | convert (ConstE x) _ = unitArrow x . it 70 | convert (Var v) p = convertVar v p 71 | convert (u :^ v) p = apply . (convert u p &&& convert v p) 72 | convert (Lam q e) p = curry (convert e (p :$ q)) 73 | convert (Either f g) p = curry ((convert' f ||| convert' g) . distl) 74 | where 75 | convert' :: E prim (c :=> d) -> ((a :* c) `k` d) 76 | convert' h = uncurry (convert h p) 77 | convert (Loop h) p = curry (loopC (uncurry (convert h p) . rassocP)) 78 | -- convert (CoerceE a) p = coerceC . convert a p 79 | 80 | -- TODO: Rewrite convert to share convert' and use for Either and Loop. 81 | -- Maybe swap arguments for better partial application. 82 | 83 | #if 0 84 | 85 | -- For Loop, we have 86 | 87 | p :: Pat u 88 | Loop h :: E p (a -> b) 89 | h :: E p (a :* s -> b :* s) 90 | 91 | convert h p :: u `k` (a :* s :=> b :* s) 92 | 93 | loopC :: ((a :* s) `k` (b :* s)) -> (a `k` b) 94 | 95 | -- and we need 96 | 97 | convert (Loop h) p :: u `k` (a :=> b) 98 | 99 | -- One step at a time: 100 | 101 | convert h p :: u `k` (a :* s :=> b :* s) 102 | uncurry (convert h p) :: (u :* (a :* s)) `k` (b :* s) 103 | uncurry (convert h p) . rassocP :: ((u :* a) :* s) `k` (b :* s) 104 | loopC (uncurry (convert h p) . rassocP) :: (u :* a) `k` b 105 | curry (loopC (uncurry (convert h p) . rassocP)) :: u `k` (a :=> b) 106 | 107 | #endif 108 | 109 | #else 110 | 111 | infixl 9 @@ 112 | infixr 2 |||| 113 | 114 | class HasLambda e where 115 | type PrimT e :: * -> * 116 | constL :: PrimT e a -> e a 117 | varL :: V a -> e a 118 | (@@) :: e (a :=> b) -> e a -> e b 119 | lamL :: Pat a -> e b -> e (a :=> b) 120 | (||||) :: e (a -> c) -> e (b -> c) -> e (a :+ b -> c) 121 | 122 | -- TODO: coerceL 123 | 124 | instance HasLambda (E p) where 125 | type PrimT (E p) = p 126 | constL = ConstE 127 | varL = Var 128 | (@@) = (:^) 129 | lamL = Lam 130 | (||||) = Either 131 | 132 | -- | Generation of CCC terms in a binding context 133 | newtype MkC prim b = 134 | MkC { unMkC :: forall a k. BiCCCC' k prim => Pat a -> (a `k` b) } 135 | 136 | instance HasLambda (MkC prim) where 137 | type PrimT (MkC prim) = prim 138 | constL x = MkC (\ _ -> unitArrow x . it) 139 | varL y = MkC (\ p -> convertVar y p) 140 | MkC u @@ MkC v = MkC (\ p -> apply . (u p &&& v p)) 141 | lamL q (MkC u) = MkC (\ p -> curry (u (p :$ q))) 142 | MkC f |||| MkC g = 143 | MkC (\ p -> curry ((uncurry (f p) ||| uncurry (g p)) . distl)) 144 | 145 | -- | Convert from 'E' to another 'HasLambda' with the same primitives: 146 | convert :: HasLambda ex => E (PrimT ex) b -> ex b 147 | convert (ConstE o) = constL o 148 | convert (Var v) = varL v 149 | convert (s :^ t) = convert s @@ convert t 150 | convert (Lam p e) = lamL p (convert e) 151 | convert (Either f g) = convert f |||| convert g 152 | convert (CoerceE e) = coerce (convert e) 153 | 154 | -- | Rewrite a lambda expression via CCC combinators 155 | toCCC :: BiCCCC' k p => E p a -> (Unit `k` a) 156 | toCCC e = unMkC (convert e) UnitPat 157 | 158 | -- A universal instance of 'HasLambda', with 'PrimT' @p@. 159 | newtype Lambda p a = L (forall f . (HasLambda f, PrimT f ~ p) => f a) 160 | 161 | instance HasLambda (Lambda p) where 162 | type PrimT (Lambda p) = p 163 | constL o = L (constL o) 164 | varL x = L (varL x) 165 | L u @@ L v = L (u @@ v) 166 | lamL p (L u) = L (lamL p u) 167 | L f |||| L g = L (f |||| g) 168 | 169 | #endif 170 | 171 | -- | Variant on 'toCCC' 172 | toCCC' :: BiCCCC' k p => E p (a :=> b) -> (a `k` b) 173 | toCCC' = unUnitFun . toCCC 174 | 175 | -- toCCC' :: forall p a b. E p (a :=> b) -> forall k. BiCCCC' k p => (a `k` b) 176 | 177 | -- TODO: Handle constants in a generic manner, so we can drop the constraint that k ~ (:->). 178 | 179 | -- convert k (Case (a,p) (b,q) ab) = 180 | -- (convert (k :$ a) p ||| convert (k :$ b) q) . ldistribS . (Id &&& convert k ab) 181 | 182 | -- Convert a variable in context 183 | convertVar :: forall b a k. ({- NatCat k,-} ProductCat k) => 184 | V b -> Pat a -> (a `k` b) 185 | convertVar u = fromMaybe (error $ "convert: unbound variable: " ++ show u) . 186 | conv 187 | where 188 | conv :: forall c. Pat c -> Maybe (c `k` b) 189 | conv (VarPat v) | Just Refl <- v ===? u = Just id 190 | | otherwise = Nothing 191 | conv UnitPat = Nothing 192 | conv (p :$ q) = ((. exr) <$> conv q) `mplus` ((. exl) <$> conv p) 193 | conv (p :@ q) = conv q `mplus` conv p 194 | -- conv ZeroPat = Nothing 195 | -- conv (SuccPat p) = (. predA) <$> conv p 196 | 197 | -- Note that we try q before p. This choice cooperates with uncurrying and 198 | -- shadowing. 199 | 200 | -- Alternatively, 201 | -- 202 | -- conv (p :$ q) = descend exr q `mplus` descend exl p 203 | -- where 204 | -- descend :: (c `k` d) -> Pat d -> Maybe (c `k` b) 205 | -- descend sel r = (. sel) <$> conv r 206 | 207 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/CoerceEncode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, PatternGuards #-} 2 | {-# LANGUAGE FlexibleContexts, ConstraintKinds #-} 3 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 7 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 8 | 9 | ---------------------------------------------------------------------- 10 | -- | 11 | -- Module : LambdaCCC.CoerceEncode 12 | -- Copyright : (c) 2014 Tabula, Inc. 13 | -- 14 | -- Maintainer : conal@tabula.com 15 | -- Stability : experimental 16 | -- 17 | -- Transform away all non-standard types 18 | ---------------------------------------------------------------------- 19 | 20 | module LambdaCCC.CoerceEncode where 21 | 22 | -- TODO: Explicit exports 23 | 24 | -- import Prelude hiding (id,(.)) 25 | 26 | import Data.Functor ((<$>)) 27 | import Control.Applicative (liftA2) 28 | import Control.Arrow (second) 29 | import Data.Maybe (fromMaybe) 30 | 31 | import CoreArity (etaExpand) 32 | 33 | import HERMIT.GHC 34 | import HERMIT.Kure 35 | import HERMIT.Core (CoreProg(..)) 36 | 37 | import HERMIT.Extras hiding (findTyConT, labeled) 38 | 39 | -- -- import qualified Type 40 | -- import Unify (tcUnifyTys,BindFlag(BindMe)) 41 | 42 | class Standardizable a where standardize :: Unop a 43 | 44 | isStandardType :: Type -> Bool 45 | isStandardType t = any ($ t) [isUnitTy,isBoolTy,isIntTy] 46 | 47 | tracing :: Bool 48 | tracing = False 49 | 50 | ttrace :: String -> a -> a 51 | ttrace | tracing = trace 52 | | otherwise = flip const 53 | 54 | instance Standardizable CoreExpr where 55 | standardize x | ttrace ("standardize expr\n" ++ unsafeShowPpr x) False = undefined 56 | standardize e@(Type {}) = e 57 | standardize e@(Coercion {}) = e 58 | standardize e@(Lit _) = e 59 | standardize e@(collectArgs -> ( Var (isDataConWorkId_maybe -> Just con) 60 | , filter (not.isTyCoArg) -> valArgs )) 61 | | isStandardType (exprType e) = ttrace "standard expression type" $ 62 | e 63 | | let argsNeeded = dataConSourceArity con - length valArgs, argsNeeded > 0 = 64 | ttrace "eta-expand unsaturated constructor application" 65 | standardize (etaExpand argsNeeded e) 66 | | otherwise = 67 | ttrace ("standardize constructor application") $ 68 | castTo (exprType e) 69 | (foldT (mkCoreTup []) (\ u v -> mkCoreTup [u,v]) 70 | (toTree (map standardize valArgs))) 71 | standardize e@(Var {}) = e 72 | standardize (App u v) = App (standardize u) (standardize v) 73 | standardize (Lam x e) = Lam x (standardize e) 74 | standardize (Let b e) = Let (standardize b) (standardize e) 75 | standardize (Case e w ty [alt]) = 76 | case' (castTo ety' (standardize e)) (onVarType (const ety') w') ty [alt'] 77 | where 78 | -- We may rewrite an alt to use wild, so update its OccInfo to unknown. 79 | -- TODO: Only update if used. 80 | -- TODO: Refactor so as not to repeat the w type change. 81 | (alt',ety') = standardizeAlt w' alt 82 | w' = setIdOccInfo w NoOccInfo 83 | standardize (Case {}) = error "standardize: multi-alternative " 84 | standardize (Cast e co) = mkCast (standardize e) co 85 | -- Alternatively, 86 | -- standardize e@(Cast e' _) = castTo (exprType e) (standardize e') 87 | standardize (Tick t e) = Tick t (standardize e) 88 | 89 | onVarType :: Unop Type -> Unop Var 90 | onVarType f v = setVarType v (f (varType v)) 91 | 92 | castTo :: Type -> CoreExpr -> CoreExpr 93 | castTo ty e = mkCast e (mkUnsafeCo (exprType e) ty) 94 | 95 | -- Now optimized by castTransitiveUnivR, as mkCast' wasn't getting there. 96 | 97 | -- castTo ty e = mkCast' e (mkUnivCo Representational (exprType e) ty) 98 | -- castTo ty (Cast e _) = castTo ty e 99 | -- castTo ty e = mkCast e (mkUnivCo Representational (exprType e) ty) 100 | 101 | -- mkCast' :: CoreExpr -> Coercion -> CoreExpr 102 | -- mkCast' (Cast e (UnivCo r t _)) (UnivCo r' _ t') | r == r' = 103 | -- mkCast' e (UnivCo r t t') 104 | -- mkCast' e co = mkCast e co 105 | 106 | -- TODO: Look into constructing axioms instead of using mkUnivCo 107 | 108 | case' :: CoreExpr -> Var -> Type -> [CoreAlt] -> CoreExpr 109 | case' scrut wild _bodyTy [(DEFAULT,[],body)] = 110 | Let (NonRec wild scrut) body 111 | case' scrut wild bodyTy alts = Case scrut wild bodyTy alts 112 | 113 | instance Standardizable CoreBind where 114 | -- standardize x | ttrace ("standardize bind " ++ unsafeShowPpr' x) False = undefined 115 | standardize (NonRec x e) = NonRec x (standardize e) 116 | standardize (Rec ves) = Rec (map (second standardize) ves) 117 | 118 | -- Standardize an alternative, yielding a new alternative and the new scrutinee 119 | -- type. 120 | standardizeAlt :: Var -> CoreAlt -> (CoreAlt,Type) 121 | standardizeAlt wild (DataAlt dc,vs,e0) = 122 | ttrace ("standardizeAlt:\n" ++ 123 | unsafeShowPpr ((dc,vs,e0),(valVars0,valVars),({-sub,-}e), alt')) $ 124 | alt' 125 | where 126 | -- TODO: why don't I need this substitution? 127 | e = -- substExpr (text "standardizeAlt") sub 128 | e0 129 | alt' | [x] <- valVars = 130 | let xty = varType x 131 | wild' = onVarType (const xty) wild in 132 | ((DEFAULT, [], standardize (subst [(x,Var wild')] e)), xty) 133 | | otherwise = 134 | ( (tupCon (length valVars), valVars, standardize e) 135 | , mkBoxedTupleTy (varType <$> valVars) ) 136 | valVars0 = filter (not . liftA2 (||) isTypeVar isCoVar) vs 137 | valVars = onVarType (substTy sub) <$> valVars0 -- needed? 138 | sub = tvSubstToSubst $ 139 | tcUnifyTys' (coVarKind <$> filter isCoVar vs) 140 | standardizeAlt _ _ = error "standardizeAlt: non-DataAlt" 141 | 142 | -- TODO: Nested case expressions when length valVars > 2. I'll have to make new 143 | -- wildcard variables, which is inconvenient here. 144 | 145 | tcUnifyTys' :: [(Type,Type)] -> TvSubst 146 | tcUnifyTys' (unzip -> (ls,rs)) = 147 | fromMaybe (error "tcUnifyTys': Nothing") $ 148 | tcUnifyTys (const BindMe) ls rs 149 | 150 | tvSubstToSubst :: TvSubst -> Subst 151 | tvSubstToSubst (TvSubst _ tsub) = 152 | Subst emptyInScopeSet emptyVarEnv tsub emptyVarEnv 153 | 154 | -- TODO: Handle length valVars > 2 correctly. I think I'll have to generate new 155 | -- wildcard variables for the new 'case' expressions. Learn standard GHC 156 | -- techniques, which I think involve checking for free and bound variables. 157 | 158 | -- TODO: is the isCoVar test redundant, i.e., are coercion variables also type 159 | -- variables? 160 | 161 | tupCon :: Int -> AltCon 162 | tupCon 1 = DEFAULT 163 | tupCon n = DataAlt (tupleCon BoxedTuple n) 164 | 165 | instance Standardizable CoreProg where 166 | standardize ProgNil = ProgNil 167 | standardize (ProgCons bind prog) = ProgCons (standardize bind) (standardize prog) 168 | 169 | -- TODO: Parametrize by bndr 170 | 171 | standardizeR :: (MonadCatch m, Standardizable a, SyntaxEq a) => 172 | Rewrite c m a 173 | standardizeR = changedArrR standardize 174 | 175 | unsafeShowPpr' :: Outputable a => a -> String 176 | unsafeShowPpr' = replace '\n' ' ' . dropMultiSpace . unsafeShowPpr 177 | where 178 | dropMultiSpace (' ':s@(' ':_)) = dropMultiSpace s 179 | dropMultiSpace (c:s) = c : dropMultiSpace s 180 | dropMultiSpace [] = [] 181 | replace a b = map (\ x -> if x == a then b else x) 182 | -------------------------------------------------------------------------------- /doc/monomorph.md: -------------------------------------------------------------------------------- 1 | # Notes on monomorphization 2 | 3 | [type-encode]: https://github.com/conal/type-encode "Haskell library" 4 | 5 | [let-float from case alternative]: https://github.com/ku-fpg/hermit/issues/113 "HERMIT issue" 6 | 7 | [over-eager `letNonRecSubstR`?]: https://github.com/ku-fpg/hermit/issues/114 "HERMIT issue" 8 | 9 | [Eliminate impossible case alternatives?]: https://github.com/ku-fpg/hermit/issues/110 "HERMIT issue" 10 | 11 | ## Motivation 12 | 13 | * Supports monomorphic back-ends like circuits with fixed data representations, simplifying down to tuples of unboxed types (not need for pointers). 14 | * As I understand it, CCCs are models of the typed lambda calculus, but not polymorphic lambda calculi. 15 | I don't know where the boundaries are. 16 | * Hopefully it will be the one and only place where we need to inline. 17 | I want to handle inlining very carefully, since it leads to code blow-up. 18 | Take care so that we do no more inlining than needed and we do it efficiently. 19 | I hope that separating from other transformations will help us do it well. 20 | 21 | ## Context 22 | 23 | My current overall plan (as of June 20, 2014) is to apply a few transformation passes: 24 | 25 | * Monomorphize. 26 | * Standardize types: 27 | * Eliminate all but a few "standard types" supported by CCCs: 28 | `()` and binary sums, binary products, and functions over standard types. 29 | Probably also `Void`, `Bool`, and maybe something like `Int#`. 30 | * For some types, use the `Encodable` class in `LambdaCCC.Encodable`, which has `encode` and `decode` methods for converting to and from a standard encoding. 31 | In particular, use these encodings for monomorphic specializations of GADTs, including length-typed vectors and depth-typed perfect leaf trees. 32 | * For other types, use a simple encoding as balanced binary sums of binary products. 33 | See [type-encode]. 34 | 35 | ## Implementation 36 | 37 | How might we implement monomorphization on Core? 38 | 39 | * Start with a monomorphic expression (probably a type specialization of a polymorphic function such as `sum` or `scanl`). 40 | * For every application of a named polymorphic value (usually a function) to type, dictionary, and coercion arguments, make a specialized version of that definition. 41 | * Memoize the specialization for reuse. 42 | * Especially useful for trees, so that the number of specialized versions is linear in the depth, i.e., logarithmic in the number of elements. 43 | * For `fmap` or `foldMap` on top-down trees, each monomorphic specialization will call the next smaller one twice. 44 | Not really, since I'm using a uniform pair functor (and will generalize to an arbitrary `Functor`, `Foldable`, `Traversable`, `Applicative`, `Monad`). 45 | Instead of two calls, there will be just one, together with a `fmap` or `foldMap` over uniform pairs. 46 | That `fmap` or `foldMap` will get type specialized just once. 47 | * For vectors, each specialization will call the next smaller once. 48 | * I can cache these definitions into HERMIT's definition stash for reuse. 49 | * I don't think I need to specialize on dictionaries, since the dictionary can be passed into the monomorphic function. 50 | On the other hand, it's probably a very good idea so that we can simplify. 51 | I'd like not to have to use the dictionary itself in the stash key. 52 | How can I know that the dictionary is fully determined by the type arguments? 53 | Seeing `f ty dict`, how do I know that this `dict` was inserted by the type-checker based on `f ty`? 54 | 55 | Sketch of a simple prototype: 56 | 57 | * Repeatedly: 58 | * Reach into an expression to find a name applied to type, dictionary, and coercion arguments. 59 | Unfold, simplify, and `let-intro`, using the expression itself to generate a name. 60 | * Hoist the `let` up as far as it can go, using `let-intro` from the top. 61 | * Remember when we introduce a name by storing the generated variable in definition stash. 62 | The RHS of that def doesn't matter. 63 | Before unfolding etc, check the stash, i.e., memoize. 64 | * Prune away impossible alternatives in `case` expressions by looking for coercion parameters with uninhabited kinds in constructor patterns (for GADTs). 65 | I don't know how to do this step, and I don't know how to generate finite code without it. 66 | See the HERMIT's issue [Eliminate impossible case alternatives?]. 67 | 68 | For removing impossible `case` alternatives, maybe there's another way if we mix in type encoding. 69 | Given a `case` scrutinee, see if it's in `Encodable`. 70 | If so, then 71 | 72 | > case scrut of alts 73 | > == case decode (encode scrut) of alts 74 | > == let x = encode scrut in case decode x of alts 75 | 76 | Then monomorphize the `encode` and `decode` applications and simplify, just as usual. 77 | For the instances I have in mind, `encode` will generate a `case` expression with just one alternative, and `decode` will generate a `case` whose scrutinee has a known constructor. 78 | 79 | I think this trick will work, and it'll be fairly easy to try, given what I've done before. 80 | A drawback is that it does more than monomorphize. 81 | 82 | ## Try it! 83 | 84 | In lambda-ccc/test, 85 | 86 | ```haskell 87 | bash-3.2$ hermit Mono.hs -v0 -opt=LambdaCCC.Monomorphize DoMono.hss 88 | [starting HERMIT v0.5.0.0 on Mono.hs] 89 | % ghc Mono.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fexpose-all-unfoldings -fplugin=LambdaCCC.Monomorphize -fplugin-opt=LambdaCCC.Monomorphize:-v0 -fplugin-opt=LambdaCCC.Monomorphize:DoMono.hss -fplugin-opt=LambdaCCC.Monomorphize:*: -v0 90 | sum4 :: Tree (S (S Z)) Int -> Int 91 | sum4 = sum (Tree (S (S Z))) Int ($fFoldableTree (S (S Z))) $fNumInt 92 | hermit<1> one-td monomorphize >>> try (any-bu bindUnLetIntroR) >>> try (any-bu let-float') >>> try simplifyAllRhs >>> try unshadow 93 | <1> memo save: sum_@_(Tree_(S_(S_Z)))_@_Int_($fFoldableTree_@_(S_(S_Z)))_$fNumInt 94 | g :: Tree (S (S Z)) Int -> Sum Int 95 | g = 96 | foldMap 97 | (Tree (S (S Z))) 98 | ($fFoldableTree (S (S Z))) 99 | Int 100 | (Sum Int) 101 | ($fMonoidSum Int $fNumInt) 102 | (product1 Int |> (~# :: (Int -> Int) ~R (Int -> Sum Int))) 103 | sum4 :: Tree (S (S Z)) Int -> Int 104 | sum4 = 105 | g |> (~# :: (Tree (S (S Z)) Int -> Sum Int) ~R (Tree 106 | (S (S Z)) Int -> Int)) 107 | hermit<2> one-td monomorphize >>> try (any-bu bindUnLetIntroR) >>> try (any-bu let-float') >>> try simplifyAllRhs >>> try unshadow 108 | <1> memo save: foldMap_@_(Tree_(S_(S_Z)))_($fFoldableTree_@_(S_(S_Z)))_@_Int_@_(Sum_Int)_($fMonoidSum_@_Int_$fNumInt) 109 | x :: (Int -> Sum Int) -> Tree (S (S Z)) Int -> Sum Int 110 | x = \ f ds -> 111 | case ds of wild (Sum Int) 112 | L (~# :: S (S Z) ~N Z) a1 -> f a1 113 | B n1 (~# :: S (S Z) ~N S n1) uv -> 114 | $fFoldablePair_$cfoldMap 115 | (Tree n1 Int) 116 | (Sum Int) 117 | ($fMonoidSum Int $fNumInt) 118 | ($fFoldableTree_$cfoldMap n1 119 | Int (Sum Int) ($fMonoidSum Int $fNumInt) f) 120 | uv 121 | g :: Tree (S (S Z)) Int -> Sum Int 122 | g = x (product1 Int |> (~# :: (Int -> Int) ~R (Int -> Sum Int))) 123 | sum4 :: Tree (S (S Z)) Int -> Int 124 | sum4 = 125 | g |> (~# :: (Tree (S (S Z)) Int -> Sum Int) ~R (Tree 126 | (S (S Z)) Int -> Int)) 127 | hermit<3> ... 128 | ``` 129 | 130 | ## Misc issues 131 | 132 | * HERMIT issue [let-float from case alternative]: 133 | * The `letFloatExprR` transformation doesn't cover floating out of case alternatives. 134 | * I added a `letFloatCaseAltR` in `LambdaCCC.Monomorphize`. 135 | * HERMIT issue [over-eager `letNonRecSubstR`?]. 136 | For now, I'm avoiding `letNonRecSubstR`, which means I can't use `simplifyR` or `bashR`. 137 | Instead, I'm using `bashUsingE` and a version of the standard `bash` rewriters that omits `letNonRecSubstR`. 138 | * I worry that the repeated use of `one-td` in `one-td monomorphize` is going to be inherently inefficient, leading to a lot of wasted re-traversal. 139 | I've had a terrible time with progressively slow transformation, and I want to learn how to produce more efficient HERMIT plugins while keeping a modular programming style, especially during experimentation. 140 | -------------------------------------------------------------------------------- /test/fft_test.hs: -------------------------------------------------------------------------------- 1 | -- Test of the computational correctness of my current FFT candidate. 2 | -- 3 | -- Original author: David Banas 4 | -- Original date: October 3, 2015 5 | -- 6 | -- Copyright (c) 2015 David Banas; all rights reserved World wide. 7 | -- 8 | -- NOTE: I have moved general FFT expression development up to the 9 | -- top level of the TreeViz project, into the fft-ccc.hs file. 10 | -- 11 | -- Please, conduct all future explorations in general FFT 12 | -- expression, using Conal's machinery, which aren't necessarily 13 | -- intended to be compilable, but rather as a less constrained 14 | -- exploration of FFT expression alternatives, there. 15 | -- 16 | -- I'm making this change of venue, for two reasons: 17 | -- 18 | -- 1) I find this file very useful, specifically, as a staging 19 | -- area for new test cases, intended for insertion into Conal's 20 | -- TreeTest.hs file, where they will actually be compiled 21 | -- by his machinery. 22 | -- 23 | -- 2) I'm realizing that a less constrained (by the requirements 24 | -- for compilation) vehicle for general exploration of more 25 | -- abstract, higher level expressions of the FFT operation, 26 | -- using Conal's data types and there associated functions, as 27 | -- well as others (potentially) would be very useful. 28 | -- 29 | -- 3) I'd like to start a wiki page, which would track the history 30 | -- of this more generic development of FFT expression, and the 31 | -- TreeViz project seems a natural base for such an effort, 32 | -- desparately needing a wiki of its own to narrate the history 33 | -- of the effort to search for more efficient FFT implementations. 34 | 35 | {-# LANGUAGE GADTs #-} 36 | {-# LANGUAGE TemplateHaskell #-} 37 | {-# LANGUAGE TypeSynonymInstances #-} 38 | {-# LANGUAGE MultiParamTypeClasses #-} 39 | {-# LANGUAGE FlexibleInstances #-} 40 | {-# LANGUAGE FlexibleContexts #-} 41 | 42 | module Main where 43 | 44 | import Prelude hiding ({- id,(.), -}foldl,foldr,sum,product,zipWith,reverse,and,or,scanl,minimum,maximum) 45 | 46 | import Control.Applicative 47 | import Control.Arrow 48 | import Control.Monad (forM_, unless) 49 | import Data.Complex 50 | import Data.Foldable (Foldable, sum, foldl', toList) 51 | import Data.Newtypes.PrettyDouble 52 | import System.Exit (exitFailure) 53 | import TypeUnary.Nat (IsNat, Nat(..), nat, N2, N3, N4, N5) -- , N6) 54 | 55 | -- import Test.QuickCheck (choose, vectorOf, elements, collect) 56 | import Test.QuickCheck (choose, vectorOf) 57 | import Test.QuickCheck.Arbitrary 58 | import Test.QuickCheck.All (quickCheckAll) 59 | 60 | import Circat.Scan (lproducts, LScan) 61 | import qualified Circat.Pair as P 62 | import qualified Circat.RTree as RT 63 | import Circat.RTree (bottomSplit) 64 | 65 | type RTree = RT.Tree 66 | 67 | -- FFT, as a class 68 | -- (The LScan constraint comes from the use of 'lproducts', in 'addPhase'.) 69 | class (LScan f) => FFT f a where 70 | fft :: f a -> f a -- Computes the FFT of a functor. 71 | 72 | -- Note that this definition of the FFT instance for Pair assumes DIT. 73 | -- How can we eliminate this assumption and make this more general? 74 | instance (RealFloat a, Applicative f, Foldable f, Num (f (Complex a)), FFT f (Complex a)) => FFT P.Pair (f (Complex a)) where 75 | fft = P.inP (uncurry (+) &&& uncurry (-)) . P.secondP addPhase . fmap fft 76 | 77 | instance (IsNat n, RealFloat a) => FFT (RTree n) (Complex a) where 78 | fft = fft' nat 79 | where fft' :: (RealFloat a) => Nat n -> RTree n (Complex a) -> RTree n (Complex a) 80 | fft' Zero = id 81 | fft' (Succ _) = inDIT fft 82 | where inDIT g = RT.toB . g . bottomSplit 83 | 84 | -- Adds the proper phase adjustments to a functor containing Complex RealFloats, 85 | -- and instancing Num. 86 | addPhase :: (Applicative f, Foldable f, LScan f, RealFloat a, Num (f (Complex a))) => f (Complex a) -> f (Complex a) 87 | addPhase = liftA2 (*) id phasor 88 | where phasor f = fst $ lproducts (pure phaseDelta) 89 | where phaseDelta = cis ((-pi) / fromIntegral n) 90 | n = flen f 91 | 92 | -- Gives the "length" (i.e. - number of elements in) of a Foldable. 93 | -- (Soon, to be provided by the Foldable class, as "length".) 94 | flen :: (Foldable f) => f a -> Int 95 | flen = foldl' (flip ((+) . const 1)) 0 96 | 97 | -- Test config. 98 | realData :: [[PrettyDouble]] 99 | realData = [ [1.0, 0.0, 0.0, 0.0] -- Delta 100 | , [1.0, 1.0, 1.0, 1.0] -- Constant 101 | , [1.0, -1.0, 1.0, -1.0] -- Nyquist 102 | , [1.0, 0.0, -1.0, 0.0] -- Fundamental 103 | , [0.0, 1.0, 0.0, -1.0] -- Fundamental w/ 90-deg. phase lag 104 | ] 105 | complexData :: [[Complex PrettyDouble]] 106 | complexData = map (map (:+ 0.0)) realData 107 | 108 | myTree2 :: [a] -> RTree N2 a 109 | myTree2 [w, x, y, z] = RT.tree2 w x y z 110 | myTree2 _ = error "Something went horribly wrong!" 111 | 112 | myTree3 :: [a] -> RTree N3 a 113 | myTree3 [a, b, c, d, e, f, g, h] = RT.tree3 a b c d e f g h 114 | myTree3 _ = error "Something went horribly wrong!" 115 | 116 | myTree4 :: [a] -> RTree N4 a 117 | myTree4 [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p] = RT.tree4 a b c d e f g h i j k l m n o p 118 | myTree4 _ = error "Something went horribly wrong!" 119 | 120 | myTree5 :: [a] -> RTree N5 a 121 | myTree5 [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, 122 | a', b', c', d', e', f', g', h', i', j', k', l', m', n', o', p'] = 123 | RT.tree5 a b c d e f g h i j k l m n o p a' b' c' d' e' f' g' h' i' j' k' l' m' n' o' p' 124 | myTree5 _ = error "Something went horribly wrong!" 125 | 126 | -- myTree6 :: [a] -> RTree N6 a 127 | -- myTree6 [a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, 128 | -- a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, 129 | -- a3, b3, c3, d3, e3, f3, g3, h3, i3, j3, k3, l3, m3, n3, o3, p3, 130 | -- a4, b4, c4, d4, e4, f4, g4, h4, i4, j4, k4, l4, m4, n4, o4, p4] = 131 | -- RT.tree6 a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1 p1 132 | -- a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2 p2 133 | -- a3 b3 c3 d3 e3 f3 g3 h3 i3 j3 k3 l3 m3 n3 o3 p3 134 | -- a4 b4 c4 d4 e4 f4 g4 h4 i4 j4 k4 l4 m4 n4 o4 p4 135 | -- myTree6 _ = error "Something went horribly wrong!" 136 | 137 | -- Discrete Fourier Transform (DFT) (our "truth" reference) 138 | -- O(n^2) 139 | -- 140 | dft :: RealFloat a => [Complex a] -> [Complex a] 141 | dft xs = [ sum [ x * exp((0.0 :+ (-1.0)) * 2 * pi / lenXs * fromIntegral(k * n)) 142 | | (x, n) <- Prelude.zip xs [0..] 143 | ] 144 | | k <- [0..(length xs - 1)] 145 | ] 146 | where lenXs = fromIntegral $ length xs 147 | 148 | -- QuickCheck types & propositions 149 | newtype FFTTestVal = FFTTestVal { 150 | getVal :: [Complex PrettyDouble] 151 | } deriving (Show) 152 | instance Arbitrary FFTTestVal where 153 | arbitrary = do 154 | xs <- vectorOf 32 $ choose (-1.0::Double, 1.0) 155 | let zs = map ((:+ 0) . PrettyDouble) xs 156 | return $ FFTTestVal zs 157 | 158 | prop_fft_test_N2 :: FFTTestVal -> Bool 159 | prop_fft_test_N2 testVal = fft (myTree2 zs) == RT.fromList (dft zs) 160 | where zs = take 4 $ getVal testVal 161 | 162 | prop_fft_test_N3 :: FFTTestVal -> Bool 163 | prop_fft_test_N3 testVal = fft (myTree3 zs) == RT.fromList (dft zs) 164 | where zs = take 8 $ getVal testVal 165 | 166 | prop_fft_test_N4 :: FFTTestVal -> Bool 167 | prop_fft_test_N4 testVal = fft (myTree4 zs) == RT.fromList (dft zs) 168 | where zs = take 16 $ getVal testVal 169 | 170 | prop_fft_test_N5 :: FFTTestVal -> Bool 171 | prop_fft_test_N5 testVal = fft (myTree5 zs) == RT.fromList (dft zs) 172 | where zs = take 32 $ getVal testVal 173 | 174 | -- Test definitions & choice 175 | basicTest :: IO () 176 | basicTest = forM_ complexData (\x -> do 177 | putStr "\nTesting input: " 178 | print x 179 | putStr "Expected output: " 180 | print $ dft x 181 | putStr "Actual output: " 182 | print $ toList (fft (myTree2 x)) 183 | ) 184 | 185 | -- This weirdness is required, as of GHC 7.8. 186 | return [] 187 | 188 | runTests :: IO Bool 189 | runTests = $quickCheckAll 190 | -- End weirdness. 191 | 192 | advancedTest :: IO () 193 | advancedTest = do 194 | allPass <- runTests -- Run QuickCheck on all prop_ functions 195 | unless allPass exitFailure 196 | 197 | main :: IO () 198 | -- main = basicTest 199 | main = advancedTest 200 | -------------------------------------------------------------------------------- /src/LambdaCCC/Adder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, ViewPatterns, TupleSections, CPP #-} 2 | {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleInstances, ConstraintKinds, UndecidableInstances #-} -- for Uncurriable 4 | 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 8 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 9 | 10 | ---------------------------------------------------------------------- 11 | -- | 12 | -- Module : LambdaCCC.Adder 13 | -- Copyright : (c) 2014 Tabula, Inc. 14 | -- 15 | -- Maintainer : conal@tabula.com 16 | -- Stability : experimental 17 | -- 18 | -- Scan-based adder 19 | ---------------------------------------------------------------------- 20 | 21 | #define Testing 22 | 23 | module LambdaCCC.Adder where 24 | 25 | -- TODO: explicit exports 26 | 27 | import Prelude hiding (mapM) 28 | 29 | import Data.Monoid (Monoid(..)) 30 | import Control.Applicative (Applicative,liftA2,(<$>)) 31 | import Data.Traversable (Traversable(..)) 32 | 33 | -- import Control.Monad.Trans.State 34 | import Control.Monad.State (MonadState(..),runState) -- mtl 35 | 36 | #ifdef Testing 37 | import TypeUnary.TyNat (N2,N4) 38 | import TypeUnary.Vec (Vec,vec4) 39 | 40 | import Circat.Misc (transpose) 41 | import Circat.RTree (RTree) 42 | import qualified Circat.RTree as RT 43 | #endif 44 | 45 | import Circat.Rep 46 | import Circat.Scan 47 | import Circat.Pair 48 | import Circat.Shift (accumL) 49 | import Circat.Category (OkayArr,Uncurriable(..)) 50 | import Circat.Classes (BottomCat(..),IfCat(..),repIf) 51 | import Circat.Circuit (GenBuses(..),(:>),genBusesRep',delayCRep,tyRep,bottomRep) 52 | 53 | import Circat.Misc (xor) 54 | 55 | import LambdaCCC.Misc ((:*)) 56 | import LambdaCCC.StateTrie 57 | 58 | type Adder t = t (Pair Bool) -> t Bool :* Bool 59 | 60 | type Adder' t = Bool :* t (Pair Bool) -> t Bool :* Bool 61 | 62 | -- NOTE: the INLINE pragmas below preserve the original definitions for 63 | -- inlining. Otherwise, we sometimes get the GHC-optimized versions, in which 64 | -- operations like 'not', '(&&)', and '(||)' have been inlined to conditionals. 65 | 66 | {-------------------------------------------------------------------- 67 | One-bit adders 68 | --------------------------------------------------------------------} 69 | 70 | halfAdd :: Pair Bool -> Bool :* Bool 71 | halfAdd (a :# b) = (a `xor` b,a && b) 72 | {-# INLINE halfAdd #-} 73 | 74 | add1 :: Bool :* Pair Bool -> Bool :* Bool 75 | add1 (ci, a :# b) = (s,co) 76 | where 77 | q = a `xor` b 78 | s = q `xor` ci 79 | co = (a && b) || (ci && q) 80 | {-# INLINE add1 #-} 81 | 82 | -- Equivalently, 83 | add1' :: Bool :* Pair Bool -> Bool :* Bool 84 | add1' (ci, ab) = (s',co || co') 85 | where 86 | (s ,co ) = halfAdd ab 87 | (s',co') = halfAdd (s :# ci) 88 | {-# INLINE add1' #-} 89 | 90 | -- accumL :: Traversable t => (a :* b -> c :* a) -> (a :* t b -> t c :* a) 91 | 92 | {-------------------------------------------------------------------- 93 | mapM 94 | --------------------------------------------------------------------} 95 | 96 | add1State :: MonadState Bool m => Pair Bool -> m Bool 97 | add1State p = state (flip (curry add1) p) 98 | {-# INLINE add1State #-} 99 | 100 | adderSt :: (MonadState Bool m, Traversable t) => 101 | (m (t Bool) -> Bool -> (t Bool, Bool)) -> Adder' t 102 | adderSt run (ci,ps) = run (mapM add1State ps) ci 103 | {-# INLINE adderSt #-} 104 | 105 | adderState :: Traversable t => Adder' t 106 | adderState = adderSt runState 107 | {-# INLINE adderState #-} 108 | 109 | adderStateTrie :: Traversable t => Adder' t 110 | adderStateTrie = adderSt runStateTrie 111 | {-# INLINE adderStateTrie #-} 112 | 113 | {-------------------------------------------------------------------- 114 | traverse-based 115 | --------------------------------------------------------------------} 116 | 117 | -- type Adder' t = Bool :* t (Pair Bool) -> t Bool :* Bool 118 | 119 | -- sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a) 120 | -- traverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) 121 | 122 | 123 | {-------------------------------------------------------------------- 124 | accum-based 125 | --------------------------------------------------------------------} 126 | 127 | adderAccumL :: Traversable t => Adder' t 128 | adderAccumL = accumL add1 129 | {-# INLINE adderAccumL #-} 130 | 131 | -- Operationally (and denotationally) equivalent to adderState, unsurprisingly, 132 | -- since they both use State. 133 | 134 | {-------------------------------------------------------------------- 135 | Scan-based 136 | --------------------------------------------------------------------} 137 | 138 | -- | Generate and propagate carries 139 | data GenProp = GenProp { gpGen :: Bool, gpProp :: Bool } 140 | 141 | type instance Rep GenProp = Bool :* Bool 142 | instance HasRep GenProp where 143 | repr (GenProp g p) = (g,p) 144 | abst (g,p) = GenProp g p 145 | 146 | -- MSB on left 147 | instance Monoid GenProp where 148 | mempty = GenProp False True 149 | GenProp gy py `mappend` GenProp gx px = 150 | GenProp (gx || gy && px) (px && py) 151 | -- {-# INLINE mempty #-} 152 | -- {-# INLINE mappend #-} 153 | 154 | genProp :: Pair Bool -> GenProp 155 | genProp (a :# b) = GenProp (a && b) (a `xor` b) 156 | -- {-# INLINE genProp #-} 157 | 158 | gpCarry :: GenProp -> Bool -> Bool 159 | gpCarry (GenProp g p) cin = g || p && cin -- TODO: consolidate with mappend 160 | -- {-# INLINE gpCarry #-} 161 | 162 | scanAdd :: (Applicative t, LScan t) => Adder t 163 | scanAdd ts = (liftA2 h gprs cs, co) 164 | where 165 | gprs = genProp <$> ts 166 | (cs,co) = gpGen <*$> lscan gprs 167 | h (GenProp _ p) ci = p `xor` ci 168 | -- {-# INLINE scanAdd #-} 169 | 170 | -- Just for testing 171 | scanGPs :: (Applicative t, LScan t) => t (Pair Bool) -> t GenProp :* GenProp 172 | scanGPs ts = lscan (genProp <$> ts) 173 | -- {-# INLINE scanGPs #-} 174 | 175 | scanAdd' :: (Applicative t, LScan t) => Adder' t 176 | scanAdd' (ci0,ts) = (liftA2 h gprs cs, co) 177 | where 178 | gprs = genProp <$> ts 179 | (cs,co) = flip gpCarry ci0 <*$> lscan gprs 180 | h (GenProp _ p) ci = p `xor` ci 181 | -- {-# INLINE scanAdd' #-} 182 | 183 | -- TODO: perhaps define a variant of lscan that takes an initial and tweaks all 184 | -- values accordingly. 185 | 186 | -- scanAdd via scanAdd' 187 | scanAdd'' :: (Applicative t, LScan t) => Adder t 188 | scanAdd'' = carryIn False scanAdd' 189 | 190 | -- carryIn :: Bool -> Adder' t -> Adder t 191 | carryIn :: c -> (c :* a -> b) -> a -> b 192 | carryIn cin f = f . (cin,) 193 | 194 | instance GenBuses GenProp where 195 | genBuses' = genBusesRep' 196 | delay = delayCRep 197 | ty = tyRep 198 | 199 | instance BottomCat (:>) GenProp where bottomC = bottomRep 200 | 201 | instance IfCat (:>) (Rep GenProp) => IfCat (:>) GenProp where ifC = repIf 202 | 203 | instance OkayArr k a GenProp => Uncurriable k a GenProp where uncurries = id 204 | 205 | -- Illegal constraint ‘OkayArr 206 | -- k a GenProp’ in a superclass/instance context 207 | -- (Use UndecidableInstances to permit this) 208 | 209 | -- Handy operations 210 | 211 | (<$*>), mapr :: Functor t => (a -> b) -> (a :* t a) -> (b :* t b) 212 | f <$*> (a,as) = (f a, f <$> as) 213 | mapr = (<$*>) 214 | 215 | (<*$>), mapl :: Functor t => (a -> b) -> (t a :* a) -> (t b :* b) 216 | f <*$> (as,a) = (f <$> as, f a) 217 | mapl = (<*$>) 218 | 219 | #ifdef Testing 220 | 221 | {-------------------------------------------------------------------- 222 | Testing addition 223 | --------------------------------------------------------------------} 224 | 225 | v4a, v4b :: Vec N4 Bool 226 | v4a = vec4 True False True True 227 | v4b = vec4 True True False True 228 | 229 | rt2a, rt2b :: RTree N2 Bool 230 | rt2a = RT.tree2 True False True True 231 | rt2b = RT.tree2 True True False True 232 | 233 | -- type Adder' t = Bool :* t (Pair Bool) -> t Bool :* Bool 234 | 235 | -- (elemsV [False,False,False,True],True) 236 | addStateV4F :: Vec N4 Bool :* Bool 237 | addStateV4F = adderState (False,transpose (v4a :# v4b)) 238 | 239 | -- (elemsV [True,False,False,True],True) 240 | addStateV4T :: Vec N4 Bool :* Bool 241 | addStateV4T = adderState (True,transpose (v4a :# v4b)) 242 | 243 | addStateTrieV4F :: Vec N4 Bool :* Bool 244 | addStateTrieV4F = adderStateTrie (False,transpose (v4a :# v4b)) 245 | 246 | addStateTrieV4T :: Vec N4 Bool :* Bool 247 | addStateTrieV4T = adderStateTrie (True,transpose (v4a :# v4b)) 248 | 249 | -- (elemsV [False,False,False,True],True) 250 | scanAddV4F :: RTree N2 Bool :* Bool 251 | scanAddV4F = scanAdd' (False,transpose (rt2a :# rt2b)) 252 | 253 | -- (elemsV [True,False,False,True],True) 254 | scanAddV4T :: RTree N2 Bool :* Bool 255 | scanAddV4T = scanAdd' (True,transpose (rt2a :# rt2b)) 256 | 257 | #endif 258 | -------------------------------------------------------------------------------- /src/LambdaCCC/CRC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeOperators, ViewPatterns, ConstraintKinds #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 8 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 9 | 10 | ---------------------------------------------------------------------- 11 | -- | 12 | -- Module : LambdaCCC.CRC 13 | -- Copyright : (c) 2014 Tabula, Inc. 14 | -- 15 | -- Maintainer : conal@tabula.com 16 | -- Stability : experimental 17 | -- 18 | -- CRC computations 19 | ---------------------------------------------------------------------- 20 | 21 | module LambdaCCC.CRC where 22 | 23 | -- TODO: explicit exports 24 | 25 | import Prelude hiding (foldl,scanl,sum) 26 | 27 | import Control.Applicative -- (Applicative(..),liftA2,liftA3) 28 | import Data.Foldable (Foldable(..),sum) 29 | import Data.Traversable (Traversable(..)) 30 | -- import Control.Category (id,(.)) 31 | -- import Control.Arrow ((&&&)) 32 | 33 | import LambdaCCC.Misc (Unop,xor,(:*)) -- ,dup 34 | import Circat.Pair (Pair(..)) 35 | import Circat.Shift 36 | import Circat.Mealy (Mealy(..)) -- scanl 37 | import Circat.Circuit (GenBuses) 38 | 39 | -- TEMP 40 | import TypeUnary.Vec hiding (transpose) 41 | import Circat.RTree 42 | 43 | crcStep :: (Traversable poly, Applicative poly) => 44 | poly Bool -> poly Bool :* Bool -> poly Bool 45 | crcStep poly (shiftR -> (b0,seg')) = (if b0 then liftA2 xor poly else id) seg' 46 | 47 | -- crcStep poly (shiftR -> (b0,seg')) = liftA2 tweak poly seg' 48 | -- where 49 | -- tweak c a = (b0 && c) `xor` a 50 | 51 | #if 0 52 | tweak c a 53 | == if b then (c `xor` a) else a 54 | == if b then (c `xor` a) else (False `xor` a) 55 | == (if b then c else False) `xor` a 56 | == (b && c) `xor` a 57 | #endif 58 | 59 | -- crcStep poly (shiftR -> (b0,seg')) = 60 | -- liftA2 (\ c a -> (b0 && c) `xor` a) poly seg' 61 | 62 | -- crcStep poly (shiftR -> (b0,seg')) = liftA2 tweak poly seg' 63 | -- where 64 | -- tweak c a = (b0 && c) `xor` a 65 | 66 | crc :: (Traversable poly, Applicative poly, Traversable msg) => 67 | poly Bool -> msg Bool :* poly Bool -> poly Bool 68 | crc poly = foldlQ (crcStep poly) . shiftRF 69 | 70 | -- | Uncurried variant of 'foldl' 71 | foldlQ :: Foldable f => (b :* a -> b) -> (b :* f a -> b) 72 | foldlQ = uncurry . foldl . curry 73 | 74 | -- Equivalently, 75 | -- 76 | -- crc poly (shiftRF -> (seg',msg')) = foldlQ (crcStep poly) (seg',msg') 77 | -- = foldl (curry (crcStep poly)) seg' msg' 78 | 79 | crcEncode :: (Traversable poly, Applicative poly, Traversable msg) => 80 | poly Bool -> msg Bool -> poly Bool 81 | crcEncode poly msg = crc poly (msg, pure False) 82 | 83 | #if 0 84 | 85 | -- Curried versions (for consideration): 86 | 87 | crcStep' :: (Traversable poly, Applicative poly) => 88 | poly Bool -> poly Bool -> Bool -> poly Bool 89 | crcStep' poly seg b = (if b0 then liftA2 xor poly else id) seg' 90 | where 91 | (b0,seg') = shiftR (seg,b) 92 | 93 | crc' :: (Traversable poly, Applicative poly, Traversable msg) => 94 | poly Bool -> msg Bool -> poly Bool -> poly Bool 95 | crc' poly msg pad = foldl (crcStep' poly) seg0 msg0 96 | where 97 | (seg0,msg0) = shiftRF (msg,pad) 98 | 99 | #endif 100 | 101 | type MealyFun s a b = (a,s) -> (b,s) 102 | 103 | -- Given an input bit, 104 | 105 | -- * If $i < p$, shift the input bit into the polynomial. 106 | -- * If $p \le i < 2 p$, shift into the remainder. 107 | -- * If $2 p \le i$, do a CRC step, updating the remainder. 108 | 109 | #if 1 110 | 111 | -- Serial 112 | crcS :: forall poly. (GenBuses (poly Bool), Show (poly Bool), Applicative poly, Traversable poly) => 113 | Mealy Bool (poly Bool) 114 | crcS = Mealy h (pure False, pure False,0) 115 | where 116 | p = sizeA (undefined :: poly Bool) 117 | h :: MealyFun (poly Bool, poly Bool, Int) Bool (poly Bool) 118 | h (b,(poly,seg,i)) = (seg',(poly',seg',i')) 119 | where 120 | i' = i + 1 121 | stash q = snd (shiftR (q,b)) 122 | (poly',seg') 123 | | i < p = (stash poly,seg) 124 | | i < 2*p = (poly,stash seg) 125 | | otherwise = (poly,crcStep poly (seg,b)) 126 | {-# INLINE crcS #-} 127 | 128 | -- TODO: rewrite via scanl 129 | 130 | -- Size of a structure without looking at the structure 131 | sizeA :: forall f a. (Applicative f, Foldable f) => f a -> Int 132 | sizeA _ = sum (pure 1 :: f Int) 133 | 134 | #if 0 135 | 136 | -- Strangely, the (<) in these definitions gets inlined before I can intercept it. 137 | -- For now, repeat the definitions in TreeTest. 138 | 139 | -- Serial with static polynomial 140 | crcSKa :: forall poly. ( GS (poly Bool) 141 | , Applicative poly, Traversable poly ) => 142 | poly Bool -> Mealy Bool (poly Bool) 143 | crcSKa poly = Mealy h (pure False,0) 144 | where 145 | p = sizeA (undefined :: poly Bool) 146 | h :: MealyFun (poly Bool, Int) Bool (poly Bool) 147 | h (b,(seg,i)) = (seg',(seg',i')) 148 | where 149 | -- This version doesn't increment i past p, to prevent overflow. 150 | (seg',i') | i < p = (snd (shiftR (seg,b)), i+1) 151 | | otherwise = (crcStep poly (seg,b), i) 152 | {-# INLINE crcSKa #-} 153 | 154 | -- To simplify the circuit, output stepped even when i 157 | poly Bool -> Mealy Bool (poly Bool) 158 | crcSKb poly = Mealy h (pure False,0) 159 | where 160 | p = sizeA (undefined :: poly ()) 161 | h (b,(seg,i)) = (stepped,next) 162 | where 163 | stepped = crcStep poly (seg,b) 164 | next | i < p = (snd (shiftR (seg,b)), i+1) 165 | | otherwise = (stepped, i) 166 | {-# INLINE crcSKb #-} 167 | 168 | crcSKc :: forall poly. (GS (poly Bool), Applicative poly, Traversable poly) => 169 | poly Bool -> Mealy Bool (poly Bool) 170 | crcSKc poly = Mealy h (pure False,0) 171 | where 172 | p = sizeA (undefined :: poly ()) 173 | h (b,(seg,i)) = (stepped,(seg',i+1)) 174 | where 175 | stepped = crcStep poly (seg,b) 176 | seg' | i < p = snd (shiftR (seg,b)) 177 | | otherwise = stepped 178 | {-# INLINE crcSKc #-} 179 | #endif 180 | 181 | #endif 182 | 183 | {-------------------------------------------------------------------- 184 | Sample input 185 | --------------------------------------------------------------------} 186 | 187 | #if 0 188 | 189 | numBits :: Integral a => a -> [Bool] 190 | numBits ((`div` 2) &&& odd -> (m,b)) = b : numBits m 191 | 192 | numBitsR :: forall n. IsNat n => Int -> RTree n Bool 193 | numBitsR = fromList . take (2^d) . numBits 194 | where 195 | d = natToZ (nat :: Nat n) :: Int 196 | 197 | numBitsV :: forall n. IsNat n => Int -> Vec n Bool 198 | numBitsV = elemsV . take n . numBits 199 | where 200 | n = natToZ (nat :: Nat n) :: Int 201 | 202 | -- See "Best CRC Polynomials" by Philip Koopman. 203 | -- . 204 | 205 | #endif 206 | 207 | -- I'm putting these definitions here to work around a problem with inlining. 208 | -- Fix that problem, and move these definitions back to TreeTest.hs. 209 | 210 | class PolyD f where 211 | polyD :: f Bool 212 | -- My standard regrettable hack to help reify otherwise-single-method 213 | -- dictionaries. 214 | regrettable_hack_PolyD :: f () -> () 215 | regrettable_hack_PolyD = const () 216 | 217 | instance PolyD (Vec N1) where polyD = vec1 True 218 | instance PolyD (Vec N2) where polyD = vec2 True False 219 | instance PolyD (Vec N3) where polyD = vec3 True False True 220 | instance PolyD (Vec N4) where 221 | polyD = vec4 True False False True 222 | {-# INLINE polyD #-} 223 | instance PolyD (Vec N5) where 224 | polyD = ((polyD :: Vec N3 Bool) <+> (polyD :: Vec N2 Bool)) 225 | {-# INLINE polyD #-} 226 | 227 | instance PolyD (Tree N0) where polyD = tree0 True 228 | instance PolyD (Tree N1) where polyD = tree1 True False 229 | instance PolyD (Tree N2) where polyD = tree2 True False False True 230 | instance PolyD (Tree N3) where 231 | polyD = tree3 True False False True True False True False 232 | {-# INLINE polyD #-} 233 | instance PolyD (Tree N4) where 234 | polyD = tree4 True False False True True False True False 235 | False True True False True False True False 236 | {-# INLINE polyD #-} 237 | instance PolyD (Tree N5) where 238 | polyD = tree5 True False False True True False True False 239 | False True True False True False True False 240 | False False True True False True False False 241 | True True False True False True False True 242 | {-# INLINE polyD #-} 243 | instance PolyD (Tree N6) where 244 | polyD = B (polyD :# bumpR True polyD) 245 | {-# INLINE polyD #-} 246 | instance PolyD (Tree N7) where 247 | polyD = B (polyD :# bumpR True polyD) 248 | {-# INLINE polyD #-} 249 | instance PolyD (Tree N8) where 250 | polyD = B (polyD :# bumpR False polyD) 251 | {-# INLINE polyD #-} 252 | 253 | bumpR :: Traversable f => a -> Unop (f a) 254 | bumpR a as = snd (shiftR (as,a)) 255 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/Standardize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, PatternGuards #-} 2 | {-# LANGUAGE FlexibleContexts, ConstraintKinds #-} 3 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 7 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 8 | 9 | ---------------------------------------------------------------------- 10 | -- | 11 | -- Module : LambdaCCC.Standardize 12 | -- Copyright : (c) 2014 Tabula, Inc. 13 | -- 14 | -- Maintainer : conal@tabula.com 15 | -- Stability : experimental 16 | -- 17 | -- Transform away all non-standard types 18 | ---------------------------------------------------------------------- 19 | 20 | module LambdaCCC.Standardize (Standardizable(..), standardizeR) where 21 | 22 | -- import Prelude hiding (id,(.)) 23 | 24 | import Data.Functor ((<$>)) 25 | import Control.Applicative (liftA2) 26 | import Control.Arrow ((***)) 27 | import Data.Maybe (catMaybes) 28 | -- import Data.List (partition) 29 | 30 | import Unify (tcUnifyTys,BindFlag(..)) 31 | import CoreArity (etaExpand) 32 | 33 | import HERMIT.GHC 34 | import HERMIT.Kure 35 | import HERMIT.Core (CoreProg(..)) 36 | 37 | import HERMIT.Extras hiding (findTyConT, labeled) 38 | 39 | import qualified Type 40 | 41 | class Standardizable a where standardize :: Unop a 42 | 43 | isStandardType :: Type -> Bool 44 | isStandardType t = any ($ t) [isUnitTy,isBoolTy,isIntTy] 45 | 46 | tracing :: Bool 47 | tracing = False 48 | 49 | ttrace :: String -> a -> a 50 | ttrace | tracing = trace 51 | | otherwise = flip const 52 | 53 | instance Standardizable Type where 54 | standardize ty | ttrace ("standardize type " ++ unsafeShowPpr' ty) False = undefined 55 | standardize t | isStandardType t = -- ttrace "standard type" $ 56 | t 57 | standardize (coreView -> Just ty) = standardize ty 58 | standardize (a `FunTy` b) = standardize a `FunTy` standardize b 59 | standardize _ty@(TyConApp _tc@(tyConDataCons_maybe -> Just dcs) tcTys) 60 | | [argTys'] <- catMaybes mbs 61 | = -- foldT unitTy pairTy (toTree (map standardize argTys)) 62 | foldT unitTy pairTy (toTree argTys') 63 | -- | w <- catMaybes mbs 64 | -- , ttrace ( "standardize: data type "++ uqName (tyConName _tc) 65 | -- ++" with " ++ show (length w) 66 | -- ++" consistent constructors") False = undefined 67 | where 68 | mbs = map (dcApp (map standardize tcTys)) dcs 69 | -- map (dcApp tcTys) dcs 70 | standardize (ForAllTy v ty) = ForAllTy v (standardize ty) 71 | standardize ty = -- ttrace ("standardize unhandled type: "++ unsafeShowPpr' ty) $ 72 | ty 73 | 74 | -- Encode datacon with its data type's *already encoded* type arguments. 75 | dcApp :: [Type] -> DataCon -> Maybe [Type] 76 | dcApp tcTys dc = 77 | -- ttrace ("dcApp in:\n" ++ unsafeShowPpr beforeInfo) $ 78 | -- ttrace ("dcApp out:\n" ++ unsafeShowPpr afterInfo) $ 79 | mbArgs' 80 | where 81 | repTy = dataConRepType dc 82 | eqSpec = dataConEqSpec dc 83 | uVars = dataConUnivTyVars dc 84 | tcSub = zipOpenTvSubst uVars tcTys 85 | mbEqSub = tcUnifyTys (const BindMe) (substTyVar tcSub <$> eqVs) eqTs 86 | where (eqVs,eqTs) = unzip eqSpec 87 | bodyArgs = filter (not.isCoVarType) $ 88 | fst (splitFunTys (dropForAlls repTy)) 89 | mbArgs' = (\ eqSub -> map (Type.substTy tcSub . standardize . Type.substTy eqSub) bodyArgs) 90 | <$> mbEqSub 91 | 92 | -- -- Before and after recursive standardize 93 | -- beforeInfo = (dc,repTy,eqSpec,tcSub,mbEqSub,bodyArgs) 94 | -- afterInfo = (beforeInfo,mbArgs') 95 | 96 | onVarType :: Unop Type -> Unop Var 97 | onVarType f v = setVarType v (f (varType v)) 98 | 99 | instance Standardizable Var where 100 | -- standardize x | ttrace ("standardize var " ++ unsafeShowPpr' x) False = undefined 101 | -- standardize v = setVarType v (standardize (varType v)) 102 | -- standardize v = ttrace ("standardize type for var " ++ unsafeShowPpr' (v,varType v)) $ 103 | -- onVarType standardize v 104 | standardize v = -- ttrace ("standardize var " ++ unsafeShowPpr' (v,ty,ty')) $ 105 | ttrace ("standardize var " ++ unsafeShowPpr' (v,ty)) $ 106 | setVarType v ty' 107 | where 108 | ty = varType v 109 | ty' = standardize ty 110 | 111 | instance Standardizable CoreExpr where 112 | -- standardize x | ttrace ("standardize expr " ++ unsafeShowPpr' x) False = undefined 113 | standardize (Type t) = Type (standardize t) 114 | standardize (Coercion co) = Coercion (standardize co) 115 | standardize e@(collectArgs -> ( Var (isDataConWorkId_maybe -> Just con) 116 | , filter (not.isTyCoArg) -> valArgs )) 117 | | isStandardType (exprType e) = ttrace "standard expression type" $ 118 | e 119 | | let argsNeeded = dataConSourceArity con - length valArgs, argsNeeded > 0 = 120 | standardize (etaExpand argsNeeded e) 121 | | otherwise = 122 | ttrace ("standardize constructor application") $ 123 | foldT (mkCoreTup []) (\ u v -> mkCoreTup [u,v]) 124 | (toTree (map standardize valArgs)) 125 | | otherwise = 126 | standardize (etaExpand 1 e) 127 | standardize (Var v) = Var (standardize v) 128 | standardize e@(Lit _) = e 129 | standardize (App u v) = App (standardize u) (standardize v) 130 | standardize (Lam x e) = Lam (standardize x) (standardize e) 131 | standardize (Let b e) = Let (standardize b) (standardize e) 132 | standardize (Case e w ty alts) = 133 | case' (standardize e) 134 | w' 135 | (standardize ty) 136 | (map (standardizeAlt w (tyConAppArgs (exprType e))) alts) 137 | where 138 | -- We may rewrite an alt to use wild, so update its OccInfo to unknown. 139 | w' = setIdOccInfo (standardize w) NoOccInfo 140 | standardize (Cast e _co) = standardize e -- Experiment 141 | -- standardize (Cast e co) = mkCast e' co' 142 | -- where 143 | -- e' = standardize e 144 | -- co' = mkUnivCo (coercionRole co) (exprType e') (standardize ty') 145 | -- Pair _ ty' = coercionKind co 146 | 147 | standardize (Tick t e) = Tick t (standardize e) 148 | 149 | case' :: CoreExpr -> Var -> Type -> [CoreAlt] -> CoreExpr 150 | case' scrut wild _bodyTy [(DEFAULT,[],body)] = 151 | Let (NonRec wild scrut) body 152 | case' scrut wild bodyTy alts = Case scrut wild bodyTy alts 153 | 154 | -- standardizeConToExpr :: DataCon -> CoreExpr 155 | -- standardizeConToExpr dc = go (dataConRepType dc) 156 | -- where 157 | -- go (ForAllTy v ty) = mkLam v (go ty) 158 | -- go (FunTy a b) = 159 | -- pairTreeE (map Var valArgs) 160 | -- where 161 | -- valArgs = filter (not.isCoVarType) 162 | -- (fst (splitFunTys (dropForAlls (dataConRepType dc)))) 163 | 164 | -- pairTreeE :: [CoreExpr] -> CoreExpr 165 | -- pairTreeE = foldT (mkCoreTup []) (\ u v -> mkCoreTup [u,v]) . toTree 166 | 167 | 168 | -- isCoercion :: Expr b -> Bool 169 | -- isCoercion (Coercion _) = True 170 | -- isCoercion _ = False 171 | 172 | instance Standardizable CoreBind where 173 | -- standardize x | ttrace ("standardize bind " ++ unsafeShowPpr' x) False = undefined 174 | standardize (NonRec x e) = 175 | NonRec (standardize x) (standardize e) 176 | standardize (Rec ves) = 177 | Rec (map (standardize *** standardize) ves) 178 | 179 | -- vTy :: Var -> (Var,Type) 180 | -- vTy v = (v, varType v) 181 | 182 | standardizeAlt :: Var -> [Type] -> Unop CoreAlt 183 | standardizeAlt wild tcTys (DataAlt dc,vs,e) = 184 | -- ttrace ("standardizeAlt:\n" ++ 185 | -- unsafeShowPpr' ((dc,vTy <$> vs,e),(valVars0,valVars) 186 | -- , alt' )) $ 187 | alt' 188 | where 189 | alt' | [x] <- valVars = (DEFAULT, [], standardize (subst [(x,Var wild)] e)) 190 | | otherwise = 191 | (tupCon (length valVars), standardize <$> valVars, standardize e) 192 | valVars0 = filter (not . liftA2 (||) isTypeVar isCoVar) vs 193 | valVars = onVarType sub <$> valVars0 -- needed? 194 | sub = Type.substTy (Type.zipOpenTvSubst tvs tcTys) 195 | tvs = fst (splitForAllTys (dataConRepType dc)) 196 | standardizeAlt _ _ _ = error "standardizeAlt: non-DataAlt" 197 | 198 | tupCon :: Int -> AltCon 199 | tupCon 1 = DEFAULT 200 | tupCon n = DataAlt (tupleCon BoxedTuple n) 201 | 202 | 203 | -- TODO: I may need nested patterns, which then requires generating new 204 | -- variables. 205 | -- For now, generate n-tuples 206 | 207 | instance Standardizable Coercion where 208 | -- For now, convert coercions to universal. 209 | standardize co = 210 | mkUnivCo (coercionRole co) (standardize ty) (standardize ty') 211 | where 212 | Pair ty ty' = coercionKind co 213 | 214 | instance Standardizable CoreProg where 215 | standardize ProgNil = ProgNil 216 | standardize (ProgCons bind prog) = 217 | ProgCons (standardize bind) (standardize prog) 218 | 219 | -- TODO: Parametrize by bndr 220 | 221 | standardizeR :: (MonadCatch m, Standardizable a, SyntaxEq a) => 222 | Rewrite c m a 223 | standardizeR = changedArrR standardize 224 | 225 | unsafeShowPpr' :: Outputable a => a -> String 226 | unsafeShowPpr' = filter (/= '\n') . dropMultiSpace . unsafeShowPpr 227 | where 228 | dropMultiSpace (' ':s@(' ':_)) = dropMultiSpace s 229 | dropMultiSpace (c:s) = c : dropMultiSpace s 230 | dropMultiSpace [] = [] -------------------------------------------------------------------------------- /src/LambdaCCC/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, ConstraintKinds, CPP #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- For tests 5 | 6 | ---------------------------------------------------------------------- 7 | -- | 8 | -- Module : LambdaCCC.Tests 9 | -- Copyright : (c) 2013 Tabula, Inc. 10 | -- License : BSD3 11 | -- 12 | -- Maintainer : conal@tabula.com 13 | -- Stability : experimental 14 | -- 15 | -- Test conversion from Lambda to CCC 16 | ---------------------------------------------------------------------- 17 | 18 | module LambdaCCC.Tests where 19 | 20 | import Prelude hiding (id,(.),curry,uncurry,not) 21 | 22 | import LambdaCCC.Misc 23 | import LambdaCCC.Lambda 24 | -- import LambdaCCC.CCC 25 | import LambdaCCC.ToCCC 26 | 27 | import Circat.Prim 28 | import Circat.Category 29 | import Circat.Classes 30 | 31 | {-------------------------------------------------------------------- 32 | Convenient notation for expression building 33 | --------------------------------------------------------------------} 34 | 35 | -- TODO: Maybe eliminate this notation or move it elsewhere, since we're mainly 36 | -- translating automatically rather than hand-coding. I'm using this vocabulary 37 | -- for tests. 38 | 39 | notE :: Unop (EP Bool) 40 | notE b = ConstE NotP :^ b 41 | 42 | infixr 2 ||*, `xorE` 43 | infixr 3 &&* 44 | 45 | binop :: Prim (a -> b -> c) -> EP a -> EP b -> EP c 46 | binop op a b = ConstE op :^ a :^ b 47 | 48 | (&&*), (||*), xorE :: Binop (EP Bool) 49 | (&&*) = binop AndP 50 | (||*) = binop OrP 51 | xorE = binop XorP 52 | 53 | infixl 6 +@, -@ 54 | (+@), (-@) :: Binop (EP Int) 55 | (+@) = binop AddP 56 | (-@) = binop SubP 57 | 58 | -- TODO: Use Num and Boolean classes 59 | 60 | {-------------------------------------------------------------------- 61 | CCC conversion 62 | --------------------------------------------------------------------} 63 | 64 | #if 0 65 | 66 | toCU :: EP (a :=> b) -> (Unit :-> (a :=> b)) 67 | toCU = toCCC 68 | 69 | toC :: EP (a :=> b) -> (a :-> b) 70 | toC = toCCC' 71 | 72 | -- No instance for (HasUnitArrow (:->) Prim) 73 | 74 | #endif 75 | 76 | {-------------------------------------------------------------------- 77 | Examples 78 | --------------------------------------------------------------------} 79 | 80 | var :: Name -> EP a 81 | var = Var . V 82 | 83 | va,vb,vc :: EP Int 84 | va = var "a" 85 | vb = var "b" 86 | vc = var "c" 87 | 88 | e1 :: EP Bool 89 | e1 = ConstE (LitP (BoolL False)) 90 | 91 | e2 :: EP Bool 92 | e2 = notE e1 93 | 94 | infixr 1 :+> 95 | type a :+> b = EP (a -> b) 96 | 97 | -- not 98 | e3 :: Bool :+> Bool 99 | e3 = ConstE NotP 100 | 101 | -- \ x -> x 102 | e4 :: Int :+> Int 103 | e4 = Lam p x 104 | where 105 | (p,x) = vars "x" 106 | 107 | -- \ x -> x + x 108 | e5 :: Int :+> Int 109 | e5 = Lam p (x +@ x) 110 | where 111 | (p,x) = vars "x" 112 | 113 | -- \ x -> (x,x) 114 | e6 :: Int :+> Int :* Int 115 | e6 = Lam p (x # x) 116 | where 117 | (p,x) = vars "x" 118 | 119 | -- \ (a,b) -> not (not a && not b) 120 | e7 :: Bool :* Bool :+> Bool 121 | e7 = Lam p (notE (notE a &&* notE b)) 122 | where 123 | (p,(a,b)) = vars2 ("a","b") 124 | 125 | -- \ (a,b) -> (b,a) 126 | e8 :: Bool :* Bool :+> Bool :* Bool 127 | e8 = Lam p (b # a) where (p,(a,b)) = vars2 ("a","b") 128 | 129 | -- Half adder: \ (a,b) -> (a `xor` b, a && b) 130 | e9 :: Bool :* Bool :+> Bool :* Bool 131 | e9 = Lam p ((a `xorE` b) # (a &&* b)) -- half-adder 132 | where 133 | (p,(a,b)) = vars2 ("a","b") 134 | 135 | -- e10 :: Bool :* ((Int :=> Bool) :* (Int :=> Bool)) -> (Int :=> Bool) 136 | -- e10 = \ (p,(f,g)) a -> cond (p,(f a,g a)) 137 | 138 | {- Evaluations: 139 | 140 | > eval e1 141 | False 142 | > eval e2 143 | True 144 | > eval e3 True 145 | False 146 | > eval e4 5 147 | 5 148 | > eval e5 10 149 | 20 150 | > eval e6 10 151 | (10,10) 152 | > eval e8 (True,False) 153 | (False,True) 154 | 155 | -} 156 | 157 | {- 158 | 159 | Without Simplify and without Sugared: 160 | 161 | > toC e3 162 | apply . (curry (not . exr) . it &&& id) 163 | > toC e4 164 | id 165 | > toC e5 166 | apply . (apply . (*** Exception: unitArrow: not yet handled: add 167 | > toC e6 168 | apply . (apply . (curry (curry id . exr) . it &&& id) &&& id) 169 | > toC e7 170 | apply . (curry (not . exr) . it &&& apply . (apply . (curry (curry (uncurry (&&)) . exr) . it &&& apply . (curry (not . exr) . it &&& id . exl)) &&& apply . (curry (not . exr) . it &&& id . exr))) 171 | > toC e8 172 | apply . (apply . (curry (curry id . exr) . it &&& id . exr) &&& id . exl) 173 | > toC e9 174 | apply . (apply . (curry (curry id . exr) . it &&& apply . (apply . (curry (curry (uncurry xor) . exr) . it &&& id . exl) &&& id . exr)) &&& apply . (apply . (curry (curry (uncurry (&&)) . exr) . it &&& id . exl) &&& id . exr)) 175 | > 176 | 177 | With Simplify: 178 | 179 | > toC e3 180 | not 181 | > toC e4 182 | id 183 | > toC e5 184 | *** Exception: unitArrow: not yet handled: add 185 | > toC e6 186 | id &&& id 187 | > toC e7 188 | not . uncurry (&&) . (not . exl &&& not . exr) 189 | > toC e8 190 | exr &&& exl 191 | > toC e9 192 | uncurry xor &&& uncurry (&&) 193 | 194 | With Simplify and Sugared: 195 | 196 | > toC e3 197 | not 198 | > toC e4 199 | id 200 | > toC e5 201 | *** Exception: unitArrow: not yet handled: add 202 | > toC e6 203 | dup 204 | > toC e7 205 | not . uncurry (&&) . twiceP not 206 | > toC e8 207 | swapP 208 | > toC e9 209 | uncurry xor &&& uncurry (&&) 210 | 211 | -} 212 | 213 | #if 0 214 | 215 | ---- Tracking down a looping bug in optimized CCC construction 216 | 217 | x1 :: (a :* (b :* c)) :-> c 218 | x1 = apply . (curry (exr . exr) &&& exr) 219 | 220 | -- x2 :: p :-> q 221 | -- x2 = uncurry not 222 | 223 | -- x :: p :-> q 224 | -- x = apply . (curry (uncurry not . (it &&& id) . exr) &&& apply . (curry (exr . exr) &&& exr)) . (it &&& id) 225 | 226 | 227 | ---- 228 | 229 | -- z = apply . (curry (apply . (apply . (curry (add . exr) &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr))) &&& apply . (curry (apply . (apply . (curry (curry id . exr) &&& exl . exr) &&& exr . exr)) &&& apply . (curry (unPair . exr) &&& apply . (curry (apply . (apply . (curry (toPair . exr) &&& apply . (curry (unL . exr) &&& exl . exr)) &&& apply . (curry (unL . exr) &&& exr . exr))) &&& apply . (curry (unPair . exr) &&& apply . (curry (unB . exr) &&& apply . (curry (toB . exr) &&& apply . (curry (apply . (apply . (curry (toPair . exr) &&& apply . (curry (toL . exr) &&& apply . (apply . (curry (curry (apply . (apply . (exr . exl &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr)))) &&& curry (mul . exr)) &&& apply . (curry (unL . exr) &&& exl . exr)))) &&& apply . (curry (toL . exr) &&& apply . (apply . (curry (curry (apply . (apply . (exr . exl &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr)))) &&& curry (mul . exr)) &&& apply . (curry (unL . exr) &&& exr . exr))))) &&& apply . (curry (unPair . exr) &&& apply . (curry (unB . exr) &&& exr)))))))))) . (it &&& id) 230 | 231 | 232 | -- okay 233 | z1 :: a :* (d :* b) :-> ((Int :* Int) :=> Int) :* d 234 | z1 = curry (add . exr) &&& apply . (curry (exl . exr) &&& exr) 235 | 236 | -- -- doesn't type 237 | -- z2 :: q 238 | -- z2 = apply . (apply . z1 &&& apply . (curry (exr . exr) &&& exr)) 239 | 240 | -- okay 241 | z3 :: a1 :* (a0 :* c0) :-> c0 242 | z3 = apply . (curry (exr . exr) &&& exr) 243 | 244 | z4 :: a0 :-> (a2 :* a1) :=> (a2 :* a1) 245 | z4 = curry (apply . (apply . (curry (curry id . exr) &&& exl . exr) &&& exr . exr)) 246 | 247 | z5 :: a0 :-> (Pair a1 :=> (a1 :* a1)) 248 | z5 = curry (unPair . exr) 249 | 250 | z6 :: (a1 :* (Tree Z (a0 :* a0) :* Tree Z d0)) :-> (Pair a0 :* d0) 251 | z6 = apply . (curry (toPair . exr) &&& apply . (curry (unL . exr) &&& exl . exr)) &&& apply . (curry (unL . exr) &&& exr . exr) 252 | 253 | z7 :: a1 :-> (((a2 :=> (a0 :=> c0)) :=> ((a2 :* a0) :=> c0)) :* ((Int :* Int) :=> Int)) 254 | z7 = curry (curry (apply . (apply . (exr . exl &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr)))) &&& curry (mul . exr) 255 | 256 | -- z7 :: a1 :-> (((a2 :=> (a0 :=> c0)) :=> ((a2 :* a0) :=> c0)) :* ((Int :* Int) :=> Int)) 257 | z7' = curry (curry (apply . (apply . (exr . exl &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr)))) &&& curry (mul . exr) 258 | 259 | z8 :: (a1 :* (a0 :* Tree Z c0)) :-> c0 260 | z8 = apply . (curry (unL . exr) &&& exr . exr) 261 | 262 | -- z9 = apply . (curry (curry (apply . (apply . (exr . exl &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr)))) &&& curry (mul . exr)) &&& apply . (curry (unL . exr) &&& exr . exr) 263 | 264 | -- -- num -> 265 | -- z7 :: (a2 :* (a1 :* Tree Z (((a0 :=> b0) :* (a0 :=> b0)) :* a0))) :-> (Tree Z b0) 266 | -- z7 = apply . (curry (toL . exr) &&& apply . (apply . (curry (curry (apply . (apply . (exr . exl &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr)))) &&& curry (mul . exr)) &&& apply . (curry (unL . exr) &&& exr . exr))) 267 | 268 | -- z7 = apply . (curry (unPair . exr) &&& apply . (curry (unB . exr) &&& apply . (curry (toB . exr) &&& apply . (curry (apply . (apply . (curry (toPair . exr) &&& apply . (curry (toL . exr) &&& apply . (apply . (curry (curry (apply . (apply . (exr . exl &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr)))) &&& curry (mul . exr)) &&& apply . (curry (unL . exr) &&& exl . exr)))) &&& apply . (curry (toL . exr) &&& apply . (apply . (curry (curry (apply . (apply . (exr . exl &&& apply . (curry (exl . exr) &&& exr)) &&& apply . (curry (exr . exr) &&& exr)))) &&& curry (mul . exr)) &&& apply . (curry (unL . exr) &&& exr . exr))))) &&& apply . (curry (unPair . exr) &&& apply . (curry (unB . exr) &&& exr)))))) 269 | 270 | #endif 271 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/Standard.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ViewPatterns, PatternGuards #-} 3 | {-# LANGUAGE FlexibleContexts, ConstraintKinds #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 8 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 9 | 10 | ---------------------------------------------------------------------- 11 | -- | 12 | -- Module : LambdaCCC.Standard 13 | -- Copyright : (c) 2014 Tabula, Inc. 14 | -- 15 | -- Maintainer : conal@tabula.com 16 | -- Stability : experimental 17 | -- 18 | -- Transform away all non-standard types 19 | ---------------------------------------------------------------------- 20 | 21 | -- #define SizedTypes 22 | 23 | module LambdaCCC.Standard where 24 | 25 | -- TODO: explicit exports 26 | import Prelude hiding (id,(.)) 27 | 28 | import Control.Category (id,(.)) 29 | import Control.Arrow (arr) 30 | import Data.Functor ((<$>)) 31 | 32 | -- GHC 33 | import PrelNames (eitherTyConName) 34 | 35 | -- import HERMIT.Context 36 | -- import HERMIT.Core 37 | import HERMIT.Dictionary hiding (externals) -- re-exports HERMIT.Dictionary.* 38 | import HERMIT.External (External) 39 | import HERMIT.GHC 40 | import HERMIT.Kure 41 | import HERMIT.Plugin (hermitPlugin,phase,interactive) 42 | 43 | import HERMIT.Extras hiding (findTyConT, labeled) 44 | import qualified HERMIT.Extras as Ex 45 | 46 | #ifdef SizedTypes 47 | import LambdaCCC.Reify (unCallE1, caseSizedR) 48 | #endif 49 | 50 | {-------------------------------------------------------------------- 51 | HERMIT tools 52 | --------------------------------------------------------------------} 53 | 54 | -- Move to HERMIT.Extras 55 | 56 | {-------------------------------------------------------------------- 57 | Observing 58 | --------------------------------------------------------------------} 59 | 60 | -- (Observing, observeR', triesL, labeled) 61 | 62 | observing :: Ex.Observing 63 | observing = True 64 | 65 | labelR :: InCoreTC t => String -> RewriteH t -> RewriteH t 66 | labelR = curry (Ex.labeled observing) 67 | 68 | {-------------------------------------------------------------------- 69 | Standard types 70 | --------------------------------------------------------------------} 71 | 72 | -- TODO: Parametrize the rest of the module by 'standardTyT'. 73 | 74 | -- TODO: Consider how to eliminate Encode as well. Then simplify to 75 | -- standardTy :: Type -> Bool 76 | 77 | -- A "standard type" is built up from `Unit`, `Bool`, `Int` (for now), pairs (of 78 | -- standard types), sums, and functions, or Encode 79 | 80 | standardTyT :: Type -> TransformU () 81 | standardTyT _ | trace "standardTyT" False = undefined 82 | standardTyT (tcView -> Just ty) = standardTyT ty 83 | standardTyT (TyConApp tc args) | standardTC tc 84 | = mapM_ standardTyT args 85 | #if 1 86 | standardTyT ty@(TyConApp tc _) = 87 | -- Treat Encode applications as standard. 88 | do encodeTC <- findTyConT "LambdaCCC.Encode.Encode" 89 | if tc == encodeTC then successT else nonStandardFail ty 90 | #endif 91 | standardTyT (FunTy arg res) = 92 | standardTyT arg >> standardTyT res 93 | standardTyT ty = nonStandardFail ty 94 | 95 | nonStandardFail :: Type -> TransformU a 96 | nonStandardFail ty = 97 | do s <- showPprT ty 98 | fail ("non-standard type:\n" ++ s) 99 | 100 | -- TODO: Maybe I just want a standard outer shell. 101 | 102 | -- TODO: Maybe use coreView instead of tcView? I think it's tcView we want, 103 | -- since it just looks through type synonyms and not newtypes. 104 | 105 | -- TODO: If I remove Encode, standardTy can be Type -> Bool 106 | 107 | nonStandardTyT :: TransformH Type () 108 | nonStandardTyT = catchesM [reView,tcApp,fun] 109 | where 110 | reView = nonStandardTyT . tcViewT 111 | tcApp = do TyConApp tc _args <- idR -- use tyConAppT 112 | encodeTC <- findTyConT "LambdaCCC.Encode.Encode" 113 | guardMsg (not (tc == encodeTC || standardTC tc)) "standard tycon" 114 | -- Could alternatively check nonStandardTyT for args 115 | successT 116 | fun = funTyT successT successT (const (const ())) 117 | -- Alternatively, probe into domain and range: 118 | -- fun = funTyT nonStandardTyT successT (const (const ())) 119 | -- <+ funTyT successT nonStandardTyT (const (const ())) 120 | 121 | standardTC :: TyCon -> Bool 122 | standardTC tc = 123 | (tc `elem` [unitTyCon, boolTyCon, intTyCon]) 124 | || isPairTC tc 125 | || tyConName tc == eitherTyConName -- no eitherTyCon 126 | 127 | isTypeE :: FilterE 128 | isTypeE = typeT successT 129 | 130 | -- nonStandardE :: FilterE 131 | -- nonStandardE = traceR "nonStandardE" >> 132 | -- ((traceR "is-type" . isTypeE) <+ notM (((traceR "is-standard" .) . standardTyT . exprType') =<< idR)) 133 | 134 | -- nonStandardE = traceR "nonStandardE" >> 135 | -- (isTypeE <+ notM ((standardTyT . exprType') =<< idR)) 136 | 137 | nonStandardE :: FilterE 138 | nonStandardE = -- traceR "nonStandardE" >> 139 | (isTypeE <+ (nonStandardTyT . arr exprType')) 140 | 141 | -- Inline names with non-standard types 142 | inlineNon :: ReExpr 143 | inlineNon = labelR "inlineNon" $ 144 | isVarT >> nonStandardE >> inlineR 145 | 146 | -- I added isVarT to reduce the calls to nonStandardE. 147 | -- TODO: Try without as well, and compare times. 148 | 149 | -- Beta reduce if doing so removes a non-standard type. 150 | betaReduceNon :: ReExpr 151 | betaReduceNon = labelR "betaReduceNon" $ 152 | appT id nonStandardE (const id) >> 153 | -- traceR "betaReduceNon: passed non-standard test." >> 154 | betaReduceR 155 | 156 | -- Let-substitute if doing so removes a non-standard type. 157 | letSubstNon :: ReExpr 158 | letSubstNon = labelR "letSubstNon" $ 159 | letT (nonRecT id nonStandardE (const id)) successT (const id) >> 160 | letSubstR 161 | 162 | #ifdef SizedTypes 163 | caseSized :: ReExpr 164 | caseSized = labelR "caseSized" $ 165 | tryR (caseReduceR True) . caseSizedR 166 | 167 | stdRuleNames :: [String] 168 | stdRuleNames = ["unTreeZ'/L","unTreeS'/B"] 169 | 170 | stdRules :: ReExpr 171 | stdRules = cleanupUnfoldR . rulesR stdRuleNames 172 | 173 | -- "unTreeZ'/L" forall a . unTreeZ' (L a) = a 174 | -- "unTreeS'/B" forall p . unTreeS' (B p) = p 175 | 176 | -- These rules don't fire, perhaps due to wrapper loss. 177 | -- For now, code them directly. 178 | -- Perhaps for the same reason, I can't unCallE1 "L". 179 | 180 | unL :: ReExpr 181 | unL = do (Var f,[_sn,Type _a,_co, a]) <- callT 182 | guardMsg (uqVarName f == "L") "Not an L" 183 | return a 184 | 185 | unB :: ReExpr 186 | unB = do (Var f,[_sn,Type _a,_sm,_co, p]) <- callT 187 | guardMsg (uqVarName f == "B") "Not a B" 188 | return p 189 | 190 | unPair :: ReExpr 191 | unPair = do (Var f,[Type _a,p,q]) <- callT 192 | guardMsg (uqVarName f == ":#") "Not a (:#)" 193 | return (mkCoreTup [p,q]) 194 | 195 | -- TODO: Refactor 196 | -- TODO: Get the GHC rules working 197 | 198 | unUnTreeZL :: ReExpr 199 | unUnTreeZL = labelR "unUnTreeZL" $ 200 | unL . unCallE1 "unTreeZ'" 201 | 202 | unUnTreeSB :: ReExpr 203 | unUnTreeSB = labelR "unUnTreeSB" $ 204 | unB . unCallE1 "unTreeS'" 205 | 206 | unUnPairPair :: ReExpr 207 | unUnPairPair = labelR "unUnPairPair" $ 208 | unPair . unCallE1 "unPair'" 209 | 210 | #endif 211 | 212 | rewrites :: [ReExpr] 213 | rewrites = [ betaReduceNon 214 | , letSubstNon 215 | , inlineNon 216 | , castCastR 217 | , lamFloatCastR 218 | , labelR "castFloatAppR" castFloatAppR 219 | , labelR "caseReduceR" (caseReduceR True) 220 | , labelR "caseFloatR" caseFloatR 221 | , labelR "caseFloatArgR" (caseFloatArgR Nothing Nothing) -- ignore strictness 222 | -- , caseSized -- after caseFloatCaseR & caseReduceR 223 | -- , unUnTreeZL, unUnTreeSB, unUnPairPair 224 | -- , stdRules -- they don't match 225 | ] 226 | 227 | standardize :: ReExpr 228 | standardize = foldr (<+) (fail "standardize: nothing to do here") rewrites 229 | 230 | deepS :: ReExpr 231 | deepS = anytdE (repeatR standardize) 232 | 233 | bashStandardize :: ReExpr 234 | bashStandardize = bashExtendedWithE rewrites 235 | 236 | {-------------------------------------------------------------------- 237 | Plugin 238 | --------------------------------------------------------------------} 239 | 240 | plugin :: Plugin 241 | plugin = hermitPlugin (phase 0 . interactive externals) 242 | 243 | externals :: [External] 244 | externals = 245 | [ externC "inline-non" inlineNon "Inline var of non-standard type" 246 | , externC "beta-reduce-non" betaReduceNon "Beta reduce if doing so removes a non-standard type" 247 | , externC "let-subst-non" letSubstNon "let-subst if doing so removes a non-standard type" 248 | , externC "bash-standardize" bashStandardize "bash with non-standard type removal" 249 | , externC "simplify-expr" simplifyExprT "Invoke GHC's simplifyExpr" 250 | , externC "lam-float-cast" lamFloatCastR "Float lambda through case" 251 | , externC "cast-cast" castCastR "Coalesce nested casts" 252 | , externC "standardize" standardize "Transform away non-standard types" 253 | , externC "deep-standardize" deepS "Top-down standardize" 254 | #ifdef SizedTypes 255 | , externC "case-sized" caseSized "Case with type-sized scrutinee" 256 | , externC "standard-rules" stdRules "Apply some rules" 257 | , externC "untreezl" unUnTreeZL "unTreeZ'/L" 258 | , externC "untreesb" unUnTreeSB "unTreeS'/B" 259 | , externC "ununpairpair" unUnPairPair "unPair'/(:#)" 260 | #endif 261 | ] 262 | 263 | -- , external "smart-td" smarttdR ["..."] 264 | -- , externC "unL" unL "drop an L" 265 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/NormalizeCore.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ViewPatterns, PatternGuards #-} 3 | {-# LANGUAGE FlexibleContexts, ConstraintKinds #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 8 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 9 | 10 | ---------------------------------------------------------------------- 11 | -- | 12 | -- Module : LambdaCCC.NormalizeCore 13 | -- Copyright : (c) 2014 Tabula, Inc. 14 | -- 15 | -- Maintainer : conal@tabula.com 16 | -- Stability : experimental 17 | -- 18 | -- Transform away all non-standard types 19 | ---------------------------------------------------------------------- 20 | 21 | module LambdaCCC.NormalizeCore where 22 | 23 | -- TODO: explicit exports 24 | import Prelude hiding (id,(.),(>>)) 25 | import qualified Prelude 26 | 27 | import Control.Category (id,(.),(>>>)) 28 | import Control.Arrow (arr) 29 | import Data.Functor ((<$),(<$>)) 30 | import Data.Monoid (mempty) 31 | 32 | -- GHC 33 | import PrelNames (eitherTyConName) 34 | 35 | import HERMIT.Dictionary hiding (externals) -- re-exports HERMIT.Dictionary.* 36 | import HERMIT.External (External,ExternalName,external,(.+),CmdTag(Loop)) 37 | import HERMIT.GHC 38 | import HERMIT.Kure 39 | import HERMIT.Plugin (hermitPlugin,phase,interactive) 40 | 41 | import HERMIT.Extras hiding (findTyConT) 42 | import qualified HERMIT.Extras as Ex 43 | 44 | {-------------------------------------------------------------------- 45 | HERMIT tools 46 | --------------------------------------------------------------------} 47 | 48 | #if 0 49 | 50 | -- Move to HERMIT.Extras 51 | 52 | -- Handy for filtering with congruence transforms 53 | 54 | okay1 :: a -> () 55 | okay1 = const () 56 | 57 | okay2 :: a -> b -> () 58 | okay2 = const okay1 59 | 60 | #else 61 | -- Use mempty instead okayN 62 | 63 | -- Tighten the type of (>>). (Alternatively, choose a different operator.) 64 | infixl 1 >> 65 | (>>) :: Monad m => m () -> m b -> m b 66 | (>>) = (Prelude.>>) 67 | #endif 68 | 69 | 70 | {-------------------------------------------------------------------- 71 | Observing 72 | --------------------------------------------------------------------} 73 | 74 | -- (Observing, observeR', triesL, labeled) 75 | 76 | observing :: Ex.Observing 77 | observing = False 78 | 79 | -- labelR :: InCoreTC t => String -> RewriteH t -> RewriteH t 80 | -- labelR = curry (Ex.labeled observing) 81 | 82 | -- watchR :: InCoreTC a => String -> Unop (RewriteH a) 83 | -- watchR = labeledR 84 | 85 | -- There's a HERMIT bug (I'm pretty sure) that introduces core-lint errors. Here 86 | -- we can either turn them into a soft or hard error (rewrite failure or error). 87 | -- See 88 | 89 | #define LintDie 90 | 91 | watchR :: String -> Unop ReExpr 92 | #ifdef LintDie 93 | watchR lab r = -- lintExprT >> -- TEMP 94 | lintingExprR lab (labeled observing (lab,r)) -- hard error 95 | #else 96 | watchR lab r = labeled observing (lab,r) >>> lintExprR -- fail on core lint error. 97 | #endif 98 | 99 | {-------------------------------------------------------------------- 100 | Standard types 101 | --------------------------------------------------------------------} 102 | 103 | -- TODO: Parametrize the rest of the module by 'standardTyT'. 104 | 105 | -- TODO: Consider how to eliminate Encode as well. Then simplify to 106 | -- standardTy :: Type -> Bool 107 | 108 | -- A "standard type" is built up from `Unit`, `Bool`, `Int` (for now), pairs (of 109 | -- standard types), sums, and functions, or Encode 110 | 111 | standardTyT :: Type -> TransformU () 112 | standardTyT (tcView -> Just ty) = standardTyT ty 113 | standardTyT (TyConApp tc args) | standardTC tc 114 | = mapM_ standardTyT args 115 | standardTyT ty@(TyConApp tc _) = 116 | -- Treat Encode applications as standard. 117 | do encodeTC <- findTyConT "LambdaCCC.Encode.Encode" 118 | if tc == encodeTC then successT else nonStandardFail ty 119 | standardTyT (FunTy arg res) = 120 | standardTyT arg >> standardTyT res 121 | standardTyT ty = nonStandardFail ty 122 | 123 | standardTC :: TyCon -> Bool 124 | standardTC tc = 125 | (tc `elem` [unitTyCon, boolTyCon, intTyCon]) 126 | || isPairTC tc 127 | || tyConName tc == eitherTyConName -- no eitherTyCon 128 | 129 | nonStandardFail :: Type -> TransformU a 130 | nonStandardFail ty = 131 | do s <- showPprT . return ty 132 | fail ("non-standard type:\n" ++ s) 133 | 134 | nonStandardTyT :: TransformH Type () 135 | nonStandardTyT = notM (standardTyT =<< idR) 136 | 137 | nonStandardE :: FilterE 138 | nonStandardE = (isTypeE <+ (nonStandardTyT . arr exprType')) 139 | 140 | -- TODO: Maybe I just want a standard outer shell. 141 | 142 | -- TODO: Maybe use coreView instead of tcView? I think it's tcView we want, 143 | -- since it just looks through type synonyms and not newtypes. 144 | 145 | -- TODO: If I remove Encode, standardTy can be Type -> Bool 146 | 147 | {-------------------------------------------------------------------- 148 | Specialized traversal 149 | --------------------------------------------------------------------} 150 | 151 | -- For inlining, I want to stay out of recursive bindings. 152 | 153 | oneNoRecRhs :: Unop ReExpr 154 | oneNoRecRhs r = go 155 | where 156 | go = foldr (<+) (fail "oneNoRecRhs: nothing to do here") 157 | [ r 158 | , appOneR go go 159 | , lamOneR skipT go 160 | , letNonRecOneR skipT go go -- or not? 161 | , caseOneR go skipT skipT (const (altOneR skipT (const skipT) go)) 162 | , castOneR go skipT 163 | , tickOneR skipT go 164 | -- No type or coercion 165 | ] 166 | 167 | -- TODO: Handle recursive let but not in RHS. 168 | 169 | skipT :: Monad m => Transform c m a b 170 | skipT = fail "untried" 171 | 172 | {-------------------------------------------------------------------- 173 | Normalization 174 | --------------------------------------------------------------------} 175 | 176 | inlineFilt :: FilterE -> ReExpr 177 | inlineFilt filt = inlineR >>> accepterR' filt 178 | 179 | -- -- | Inline names with non-standard types or trivial bindings. 180 | -- inlineIt :: ReExpr 181 | -- inlineIt = watchR "inlineIt" $ 182 | -- isVarT >> (inlineNonStandard <+ inlineTrivial) 183 | -- where 184 | -- inlineNonStandard = nonStandardE >> inlineR 185 | -- inlineTrivial = inlineR >> accepterR (True <$ trivialExpr) 186 | 187 | -- inlineIt :: ReExpr 188 | -- inlineIt = watchR "inlineIt" $ 189 | -- inlineR >>> accepterR' (trivialExpr <+ nonStandardE) 190 | 191 | inlineTrivial :: ReExpr 192 | inlineTrivial = watchR "inlineTrivial" $ 193 | inlineFilt trivialExpr 194 | 195 | -- Maybe drop inlineTrivial in favor of letElimTrivialR 196 | 197 | inlineNon :: ReExpr 198 | inlineNon = watchR "inlineNon" $ 199 | inlineFilt nonStandardE 200 | 201 | -- TODO: Maybe re-implement inlineNon to check type *first*. 202 | 203 | -- inlineIt :: ReExpr 204 | -- inlineIt = watchR "inlineIt" $ 205 | -- inlineFilt (trivialExpr <+ nonStandardE) 206 | 207 | accepterR' :: (Functor m, Monad m) => Transform c m a () -> Rewrite c m a 208 | accepterR' = accepterR . (True <$) 209 | 210 | -- One step toward application normalization. 211 | appStep :: ReExpr 212 | appStep = appT successT nonStandardE mempty >> 213 | ( watchR "letFloatAppR" letFloatAppR 214 | <+ watchR "betaReduceR" betaReduceR 215 | ) 216 | 217 | -- appStep = watchR "appStep" $ 218 | -- appT successT nonStandardE mempty >> 219 | -- (letFloatAppR <+ betaReduceR) 220 | 221 | -- | Trivial expression: for now, literals, variables, casts of trivial. 222 | trivialExpr :: FilterE 223 | trivialExpr = setFailMsg "Non-trivial" $ 224 | isTypeE <+ isVarT <+ isLitT 225 | <+ trivialLam 226 | <+ castT trivialExpr id mempty 227 | 228 | trivialBind :: FilterH CoreBind 229 | trivialBind = nonRecT successT trivialExpr mempty 230 | 231 | trivialLet :: FilterE 232 | trivialLet = letT trivialBind successT mempty 233 | 234 | trivialLam :: FilterE 235 | trivialLam = lamT id trivialExpr mempty 236 | 237 | trivialBetaRedex :: FilterE 238 | trivialBetaRedex = appT trivialLam successT mempty 239 | 240 | -- These filters could instead be predicates. Then use acceptR. 241 | 242 | letElimTrivialR :: ReExpr 243 | letElimTrivialR = watchR "trivialLet" $ 244 | trivialLet >> letSubstR 245 | 246 | betaReduceTrivial :: ReExpr 247 | betaReduceTrivial = watchR "betaReduceTrivial" $ 248 | trivialBetaRedex >> betaReduceR 249 | 250 | #if 0 251 | simplifyCastR :: ReExpr 252 | simplifyCastR = watchR "simplifyCastR" $ 253 | castT id id mempty >> 254 | simplifyExprR 255 | 256 | -- ACK! simplifyExprR reports false positives, causing rewrite loop. 257 | #endif 258 | 259 | {-------------------------------------------------------------------- 260 | Put it together 261 | --------------------------------------------------------------------} 262 | 263 | simplifiers :: [ReCore] 264 | simplifiers = 265 | promoteR <$> 266 | [ appStep 267 | , betaReduceTrivial 268 | , watchR "letElimR" letElimR -- removed unused bindings after inlining 269 | , watchR "castFloatAppR'" castFloatAppR' 270 | , watchR "castCastR" castCastR 271 | , watchR "lamFloatCastR" lamFloatCastR 272 | , watchR "caseReduceR" (caseReduceR False) -- let rather than subst 273 | , watchR "caseFloatR" caseFloatR 274 | -- , watchR "caseWildR" caseWildR 275 | -- Wedging: 276 | -- , watchR "caseFloatArgR" (caseFloatArgR Nothing Nothing) -- ignore strictness 277 | , inlineTrivial 278 | , letElimTrivialR 279 | ] 280 | 281 | simplifyOne :: ReCore 282 | simplifyOne = foldr (<+) (fail "standardize: nothing to do here") simplifiers 283 | 284 | -- inlinePassAll :: ReCore 285 | -- inlinePassAll = anybuR (promoteR inlineNon) 286 | 287 | inlinePassOne :: ReCore 288 | inlinePassOne = promoteR (oneNoRecRhs inlineNon) 289 | 290 | -- inlinePassOne = onetdR (promoteR inlineNon) 291 | 292 | bashE' :: ReExpr 293 | bashE' = watchR "bashR" (extractR bashR) 294 | 295 | -- bashE' = watchR "bashR" (extractR bashR >>> lintExprR) 296 | 297 | -- Without this lintExprR, I sometimes get bad Core. Hm! 298 | 299 | bashR' :: ReCore 300 | bashR' = promoteR bashE' 301 | 302 | simplifyTD :: ReCore 303 | simplifyTD = repeatR (anytdR (repeatR simplifyOne) >>> tryR bashR') 304 | 305 | -- deepPass :: ReCore 306 | -- deepPass = inlinePassOne >>> tryR simplifyTD 307 | 308 | bashSimplifiers :: ReCore 309 | bashSimplifiers = bashExtendedWithR (promoteR <$> simplifiers) 310 | 311 | normalizeCoreBash :: ReCore 312 | normalizeCoreBash = tryR bashSimplifiers >>> 313 | repeatR (inlinePassOne >>> tryR bashSimplifiers) 314 | 315 | normalizeCore' :: ReCore 316 | normalizeCore' = tryR simplifyTD >>> 317 | repeatR (inlinePassOne >>> tryR simplifyTD) 318 | 319 | {-------------------------------------------------------------------- 320 | Plugin 321 | --------------------------------------------------------------------} 322 | 323 | plugin :: Plugin 324 | plugin = hermitPlugin (phase 0 . interactive externals) 325 | 326 | externals :: [External] 327 | externals = 328 | [ externC "simplify-one" simplifyOne "Locally simplify for normalization, without inlining" 329 | , externC "app-step" appStep "Normalize an application" 330 | , externC "inline-trivial" inlineTrivial "Inline trivial definition" 331 | , externC "let-elim-trivial" letElimTrivialR "Eliminate trivial binding" 332 | , externC "inline-non" inlineNon "Inline if non-standard type" 333 | , externC "inline-pass-one" inlinePassOne "Inlining pass for normalization" 334 | , externC "bash-simplifiers" bashSimplifiers "Bash with normalization simplifiers (no inlining)" 335 | , externC "simplify-td" simplifyTD "top-down normalize simplification" 336 | , externC "normalize-core-bash" normalizeCoreBash "Normalize via bash" 337 | , externC "normalize-core'" normalizeCore' "Normalize not via bash" 338 | -- Move to HERMIT.Extras: 339 | , externC "cast-float-app'" castFloatAppR' "cast-float-app with transitivity" 340 | , externC "cast-cast" castCastR "Coalesce nested casts" 341 | , externC "un-cast-cast" unCastCastR "Uncoalesce to nested casts" 342 | , externC "lam-float-cast" lamFloatCastR "Float lambda through case" 343 | , externC "simplify-expr" simplifyExprR "Invoke GHC's simplifyExpr" 344 | , externC "case-wild" caseWildR "case of wild ==> let (doesn't preserve evaluation)" 345 | , external "repeat" (repeatN :: Int -> Unop (RewriteH Core)) 346 | [ "Repeat a rewrite n times." ] .+ Loop 347 | ] 348 | -------------------------------------------------------------------------------- /src/LambdaCCC/CCC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, GADTs, KindSignatures, CPP #-} 2 | {-# LANGUAGE PatternGuards, ViewPatterns, ConstraintKinds #-} 3 | {-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} 4 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} -- for Int1 hack 6 | {-# OPTIONS_GHC -Wall #-} 7 | 8 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 9 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 10 | 11 | ---------------------------------------------------------------------- 12 | -- | 13 | -- Module : LambdaCCC.CCC 14 | -- Copyright : (c) 2013 Tabula, Inc. 15 | -- License : BSD3 16 | -- 17 | -- Maintainer : conal@tabula.com 18 | -- Stability : experimental 19 | -- 20 | -- GADT of CCC combinators 21 | ---------------------------------------------------------------------- 22 | 23 | -- Whether to introduce defined operations like (***) during show 24 | #define Sugared 25 | 26 | -- Whether to simplify during construction 27 | #define Simplify 28 | 29 | module LambdaCCC.CCC 30 | ( module LambdaCCC.Misc 31 | , (:->)(..), prim 32 | , convertC 33 | ) where 34 | 35 | import Prelude hiding (id,(.),curry,uncurry) 36 | -- import Data.Typeable (Typeable) 37 | -- import Data.Coerce 38 | 39 | #ifdef Simplify 40 | -- import Data.IsTy 41 | import Data.Proof.EQ 42 | #endif 43 | 44 | -- import TypeUnary.Vec (Vec(..)) 45 | 46 | import LambdaCCC.Misc (Unop,Evalable(..),Unit,(:*),(:+),(:=>),Eq'(..),(==?)) 47 | import LambdaCCC.ShowUtils (showsApp1,showsOp2',Assoc(..)) 48 | -- import LambdaCCC.Ty 49 | 50 | -- import TypeEncode.Encode (EncodeCat(..)) 51 | 52 | import Circat.Category 53 | import Circat.Classes 54 | import Circat.Prim (Prim(..),Lit(..),primArrow) -- ,cond,ifThenElse 55 | import Circat.Circuit ((:>),GenBuses) 56 | 57 | infix 0 :-> 58 | 59 | infixr 3 :&&& 60 | infixr 2 :||| 61 | 62 | -- | CCC combinator expressions. Although we use standard Haskell unit, 63 | -- cartesian product, sums, and function types here, the intended interpretation 64 | -- is as the categorical counterparts (terminal object, categorical products, 65 | -- coproducts, and exponentials). 66 | data (:->) :: * -> * -> * where 67 | Id :: a :-> a 68 | (:.) :: (b :-> c) -> (a :-> b) -> (a :-> c) 69 | -- Products 70 | Exl :: a :* b :-> a 71 | Exr :: a :* b :-> b 72 | (:&&&) :: (a :-> b) -> (a :-> c) -> (a :-> b :* c) 73 | It :: a :-> Unit 74 | -- Coproducts 75 | Inl :: a :-> a :+ b 76 | Inr :: b :-> a :+ b 77 | (:|||) :: (b :-> a) -> (c :-> a) -> (b :+ c :-> a) 78 | DistL :: a :* (b :+ c) :-> a :* b :+ a :* c 79 | -- Exponentials 80 | Apply :: (a :=> b) :* a :-> b 81 | Curry :: (a :* b :-> c) -> (a :-> (b :=> c)) 82 | Uncurry :: (a :-> (b :=> c)) -> (a :* b :-> c) 83 | -- -- Type-safe coercion 84 | -- Coerce :: (Typeable a, Typeable b, Coercible a b) => a :-> b 85 | -- -- Representation change 86 | -- Repr :: a :-> Rep a 87 | -- Abst :: Rep a :-> a 88 | -- Primitives 89 | Prim :: Prim (a :=> b) -> (a :-> b) 90 | Lit :: Lit b -> (a :-> b) 91 | 92 | -- TODO: Maybe specialize a to Unit in the type of Lit 93 | 94 | -- TODO: Try to make instances for the Category subclasses, so we don't need 95 | -- separate terminology. Then eliminate dup, jam, etc. 96 | 97 | instance Eq' (a :-> b) (c :-> d) where 98 | Id === Id = True 99 | (g :. f) === (g' :. f') = g === g' && f === f' 100 | Exl === Exl = True 101 | Exr === Exr = True 102 | (f :&&& g) === (f' :&&& g') = f === f' && g === g' 103 | Inl === Inl = True 104 | Inr === Inr = True 105 | (f :||| g) === (f' :||| g') = f === f' && g === g' 106 | DistL === DistL = True 107 | Apply === Apply = True 108 | Curry h === Curry h' = h === h' 109 | Uncurry k === Uncurry k' = k === k' 110 | Prim p === Prim p' = p === p' 111 | Lit l === Lit l' = l === l' 112 | _ === _ = False 113 | 114 | instance Eq (a :-> b) where (==) = (===) 115 | 116 | 117 | -- WARNING: take care with the (==) definition above. When we add constructors 118 | -- to the GADT, we won't get a non-exhaustive cases warning, since the last case 119 | -- is catch-all. 120 | 121 | -- TODO: The type constraints prevent (:->) from being a category etc without 122 | -- some change to those classes, e.g., with instance-specific constraints via 123 | -- ConstraintKinds. 124 | 125 | -- Maybe parametrize this GADT by a constraint. Sadly, I'd lose the pretty infix 126 | -- syntax ("a :-> b"). 127 | 128 | -- Homomorphic evaluation 129 | #if 1 130 | 131 | distlF :: a :* (b :+ c) -> a :* b :+ a :* c 132 | distlF (a, Left b) = Left (a,b) 133 | distlF (a, Right c) = Right (a,c) 134 | 135 | instance Evalable (a :-> b) where 136 | type ValT (a :-> b) = a :=> b 137 | eval Id = id 138 | eval (g :. f) = eval g . eval f 139 | eval Exl = fst 140 | eval Exr = snd 141 | eval (f :&&& g) = eval f &&& eval g 142 | eval It = it 143 | eval Inl = Left 144 | eval Inr = Right 145 | eval (f :||| g) = eval f ||| eval g 146 | eval DistL = distlF 147 | eval Apply = uncurry ($) 148 | eval (Curry h) = curry (eval h) 149 | eval (Uncurry f) = uncurry (eval f) 150 | -- eval Coerce = coerce 151 | eval (Prim p) = eval p 152 | eval (Lit l) = const (eval l) 153 | #else 154 | instance Evalable (a :-> b) where 155 | type ValT (a :-> b) = a -> b 156 | eval = convertC 157 | #endif 158 | 159 | 160 | {-------------------------------------------------------------------- 161 | Smart constructors 162 | --------------------------------------------------------------------} 163 | 164 | prim :: Prim (a -> b) -> (a :-> b) 165 | prim ExlP = Exl 166 | prim ExrP = Exr 167 | prim InlP = Inl 168 | prim InrP = Inr 169 | prim p = Prim p 170 | 171 | instance Category (:->) where 172 | id = Id 173 | -- | Optimizing morphism composition 174 | # ifdef Simplify 175 | Id . f = f 176 | g . Id = g 177 | (h :. g) . f = h . (g . f) 178 | Exl . (f :&&& _) = f 179 | Exr . (_ :&&& g) = g 180 | It . _ = it 181 | (f :||| _) . Inl = f 182 | (_ :||| g) . Inr = g 183 | -- Important but occasionally leads to nontermination. 184 | -- See https://github.com/conal/lambda-ccc/issues/14 185 | -- Apply . (decompL -> g :. f) = composeApply g . f 186 | -- Even the following simpler version trips nontermination. 187 | -- Apply . (decompL -> g :. f) = (Apply :. g) . f 188 | -- Curry (decompR -> f :. Exr) . _ = curry (f . exr) -- see below 189 | # endif 190 | g . f = g :. f 191 | 192 | 193 | -- To prove: 194 | -- 195 | -- curry (f . exr) . g == curry (f . exr) 196 | 197 | #ifdef Simplify 198 | 199 | -- | @'composeApply' h == 'apply' . h@ 200 | composeApply :: (z :-> (a :=> b) :* a) -> (z :-> b) 201 | -- apply . (curry h . f &&& g) == h . (f &&& g) 202 | composeApply ((decompL -> (Curry h :. f)) :&&& g) = h . (f &&& g) 203 | composeApply (h@Prim{} :. f :&&& g) = uncurry h . (f &&& g) 204 | composeApply (h@Prim{} :&&& g) = uncurry h . (Id &&& g) 205 | -- apply . (curry (g . exr) &&& f) == g . f 206 | composeApply (Curry (decompR -> g :. Exr) :&&& f) = g . f 207 | -- apply . first f == uncurry f -- see proof below 208 | composeApply (f :. Exl :&&& Exr) = uncurry f 209 | composeApply h = Apply :. h 210 | 211 | #endif 212 | 213 | {- 214 | apply . first f 215 | == \ p -> apply (first f p) 216 | == \ (a,b) -> apply (first f (a,b)) 217 | == \ (a,b) -> apply (f a, b) 218 | == \ (a,b) -> f a b 219 | == uncurry f 220 | -} 221 | 222 | -- Note: the ConstU{} specialization is unnecessary for validity but I suspect 223 | -- useful for introducing just the uncurryings we want. TODO: verify. 224 | -- 225 | -- Note: the second Uncurry specializes the first one, but is needed for 226 | -- syntactic matching. 227 | 228 | instance ProductCat (:->) where 229 | exl = Exl 230 | exr = Exr 231 | # ifdef Simplify 232 | -- Experimental: const a &&& const b == const (a,b) 233 | -- Prim (ConstP (LitP a)) &&& Prim (ConstP (LitP b)) = Prim (ConstP (LitP (a,b))) 234 | Exl &&& Exr = Id 235 | -- f . r &&& g . r == (f &&& g) . r 236 | (decompR -> f :. r) &&& (decompR -> g :. r') | Just Refl <- r ==? r' 237 | = (f &&& g) . r 238 | # endif 239 | f &&& g = f :&&& g 240 | 241 | instance TerminalCat (:->) where 242 | it = It 243 | 244 | instance CoproductCat (:->) where 245 | inl = Inl 246 | inr = Inr 247 | (|||) = (:|||) -- no rewrites? 248 | 249 | instance DistribCat (:->) where 250 | distl = DistL 251 | distr = (swapP +++ swapP) . distl . swapP -- maybe move to default. 252 | 253 | instance ClosedCat (:->) where 254 | apply = Apply 255 | # ifdef Simplify 256 | curry (Uncurry h) = h 257 | -- curry (apply . (f . exl &&& exr)) == f -- Proof below 258 | -- curry (Apply :. (f :. Exl :&&& Exr)) = f 259 | # endif 260 | curry h = Curry h 261 | # ifdef Simplify 262 | uncurry (Curry f) = f 263 | uncurry (Prim PairP) = Id 264 | # endif 265 | uncurry x = Uncurry x 266 | 267 | -- curry/apply proof: 268 | -- 269 | -- curry (apply . (f . exl &&& exr)) 270 | -- == curry (apply . (f . exl &&& id . exr)) 271 | -- == curry (apply . (f *** id)) 272 | -- == curry (apply . first f) 273 | -- == curry (\ (a,b) -> apply (first f (a,b))) 274 | -- == curry (\ (a,b) -> apply (f a,b)) 275 | -- == curry (\ (a,b) -> f a b) 276 | -- == f 277 | 278 | -- I commented out this rule. I don't think it'll ever fire, considering 279 | -- composeApply. 280 | 281 | -- instance CoerceCat (:->) where 282 | -- coerceC = Coerce 283 | 284 | instance RepCat (:->) where 285 | reprC = prim ReprP 286 | abstC = prim AbstP 287 | 288 | instance BottomCat (:->) where 289 | type BottomKon (:->) a = GenBuses a 290 | bottomC = prim BottomC 291 | 292 | {-------------------------------------------------------------------- 293 | Factoring (decomposition) 294 | --------------------------------------------------------------------} 295 | 296 | #if defined Simplify 297 | 298 | -- | Decompose into @g . f@, where @g@ is as small as possible, but not 'Id'. 299 | -- Pattern matching against @_ :. _@ determines whether decomposition succeeded. 300 | decompL :: Unop (a :-> c) 301 | decompL Id = Id 302 | decompL ((decompL -> h :. g) :. f) = h :. (g . f) 303 | decompL comp@(_ :. _) = comp 304 | decompL f = f :. Id 305 | 306 | #endif 307 | 308 | #if defined Simplify || defined Sugared 309 | 310 | -- | Decompose into @g . f@, where @f@ is as small as possible, but not 'Id'. 311 | -- Pattern matching against @_ :. _@ determines whether decomposition succeeded. 312 | decompR :: Unop (a :-> c) 313 | decompR Id = Id 314 | decompR (h :. (decompR -> g :. f)) = (h . g) :. f 315 | decompR comp@(_ :. _) = comp 316 | decompR f = Id :. f 317 | 318 | #endif 319 | 320 | {-------------------------------------------------------------------- 321 | Show 322 | --------------------------------------------------------------------} 323 | 324 | instance Show (a :-> b) where 325 | #ifdef Sugared 326 | showsPrec _ (Id :&&& Id ) = showString "dup" 327 | showsPrec _ (Exr :&&& Exl) = showString "swapP" 328 | showsPrec p ((decompR -> f :. Exl) :&&& (decompR -> g :. Exr)) 329 | | Id <- g = showsApp1 "first" p f 330 | | Id <- f = showsApp1 "second" p g 331 | | f === g = showsApp1 "twiceP" p f 332 | | otherwise = showsOp2' "***" (3,AssocRight) p f g 333 | showsPrec _ (Id :||| Id ) = showString "jam" 334 | showsPrec _ (Inr :||| Inl) = showString "swapC" 335 | showsPrec p ((decompR -> f :. Inl) :&&& (decompR -> g :. Inr)) 336 | | Id <- g = showsApp1 "left" p f 337 | | Id <- f = showsApp1 "right" p g 338 | | f === g = showsApp1 "twiceC" p f 339 | | otherwise = showsOp2' "+++" (2,AssocRight) p f g 340 | #endif 341 | showsPrec _ Id = showString "id" 342 | showsPrec p (g :. f) = showsOp2' "." (9,AssocRight) p g f 343 | showsPrec _ Exl = showString "exl" 344 | showsPrec _ Exr = showString "exr" 345 | showsPrec p (f :&&& g) = showsOp2' "&&&" (3,AssocRight) p f g 346 | showsPrec _ It = showString "it" 347 | showsPrec _ Inl = showString "inl" 348 | showsPrec _ Inr = showString "inr" 349 | showsPrec p (f :||| g) = showsOp2' "|||" (2,AssocRight) p f g 350 | showsPrec _ DistL = showString "distl" 351 | showsPrec _ Apply = showString "apply" 352 | showsPrec p (Curry f) = showsApp1 "curry" p f 353 | showsPrec p (Uncurry h) = showsApp1 "uncurry" p h 354 | showsPrec p (Prim x) = showsPrec p x 355 | showsPrec p (Lit l) = showsApp1 "const" p l 356 | 357 | -- -- | Category with boolean operations. 358 | -- class ProductCat k => BoolCat k where 359 | -- not :: Bool `k` Bool 360 | -- and, or, xor :: (Bool :* Bool) `k` Bool 361 | 362 | primUnc :: Prim (a :=> b :=> c) -> (a :* b :-> c) 363 | primUnc = uncurry . prim 364 | 365 | instance BoolCat (:->) where 366 | notC = prim NotP 367 | xorC = uncurry (prim XorP) 368 | andC = uncurry (prim AndP) 369 | orC = uncurry (prim OrP) 370 | 371 | -- etc. 372 | 373 | #if 0 374 | instance MuxCat (:->) where 375 | muxB = prim CondBP 376 | muxI = prim CondIP 377 | #else 378 | 379 | -- instance IfCat (:->) a where 380 | -- ifC = prim IfP 381 | 382 | -- No instance for (IfCat (Circat.Circuit.:>) a) 383 | 384 | #endif 385 | 386 | instance NumCat (:->) Int where 387 | add = primUnc AddP 388 | sub = primUnc SubP 389 | mul = primUnc MulP 390 | 391 | -- TODO: reconcile curried vs uncurried, eliminating the conversions here. 392 | 393 | {-------------------------------------------------------------------- 394 | Experiment: convert to other CCC 395 | --------------------------------------------------------------------} 396 | 397 | convertC :: -- ( BiCCCC k Lit, BoolCat k, NumCat k Int) 398 | (k ~ (:>)) 399 | => (a :-> b) -> (a `k` b) 400 | convertC Id = id 401 | convertC (g :. f) = convertC g . convertC f 402 | convertC Exl = exl 403 | convertC Exr = exr 404 | convertC (f :&&& g) = convertC f &&& convertC g 405 | convertC It = it 406 | convertC Inl = inl 407 | convertC Inr = inr 408 | convertC (f :||| g) = convertC f ||| convertC g 409 | convertC DistL = distl 410 | convertC Apply = apply 411 | convertC (Curry h) = curry (convertC h) 412 | convertC (Uncurry f) = uncurry (convertC f) 413 | convertC (Prim p) = primArrow p 414 | convertC (Lit l) = unitArrow l . it 415 | 416 | instance HasUnitArrow (:->) Lit where unitArrow = Lit 417 | -------------------------------------------------------------------------------- /src/LambdaCCC/ReifySimple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, GADTs, KindSignatures #-} 2 | {-# LANGUAGE ViewPatterns, PatternGuards #-} 3 | {-# LANGUAGE FlexibleContexts, ConstraintKinds #-} 4 | {-# LANGUAGE MagicHash, MultiWayIf, TupleSections, CPP #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# OPTIONS_GHC -Wall #-} 8 | 9 | -- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 10 | -- {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 11 | 12 | ---------------------------------------------------------------------- 13 | -- | 14 | -- Module : LambdaCCC.ReifySimple 15 | -- Copyright : (c) 2013 Tabula, Inc. 16 | -- LICENSE : BSD3 17 | -- 18 | -- Maintainer : conal@tabula.com 19 | -- Stability : experimental 20 | -- 21 | -- Reify a Core expression into GADT 22 | ---------------------------------------------------------------------- 23 | 24 | module LambdaCCC.ReifySimple 25 | ( reifyMisc, lamName, repName --, ifName 26 | , inReify -- TEMP 27 | , reifyEval, reifyIf, reifyDelay, reifyLoop, reifyBottom 28 | , reifyRepMeth, reifyApp, reifyLam, reifyMonoLet 29 | , reifyTupCase, reifyLit, reifyPrim, reifyStdMeth 30 | , reifyOops 31 | , isPrimOrRepMeth, isPrimitiveOp, isPrimitiveTy 32 | , observing 33 | ) where 34 | 35 | -- TODO: export externals instead, and use in Monomorphize 36 | 37 | import Prelude hiding (id,(.)) 38 | 39 | import Data.Functor ((<$>),void) 40 | import Control.Category (Category(..)) 41 | import Control.Monad ((<=<)) 42 | import Control.Arrow ((>>>)) 43 | import qualified Data.Map as M 44 | import Data.String (fromString) 45 | 46 | import HERMIT.Core (localFreeIdsExpr) 47 | import HERMIT.GHC hiding (mkStringExpr) 48 | import TcType (isDoubleTy) -- Doesn't seem to be coming in with HERMIT.GHC. 49 | import HERMIT.Kure -- hiding (apply) 50 | -- Note that HERMIT.Dictionary re-exports HERMIT.Dictionary.* 51 | import HERMIT.Dictionary hiding (externals) 52 | import HERMIT.Name (HermitName) 53 | 54 | import LambdaCCC.Misc ((<~)) 55 | 56 | import HERMIT.Extras hiding (findTyConT,observeR',triesL) 57 | import qualified HERMIT.Extras as Ex -- (Observing, observeR', triesL, labeled) 58 | 59 | -- Drop TypeEncode for now. 60 | -- import TypeEncode.Plugin (encodeOf, reConstructR, reCaseR) 61 | -- import qualified TypeEncode.Plugin as Enc 62 | 63 | {-------------------------------------------------------------------- 64 | Observing 65 | --------------------------------------------------------------------} 66 | 67 | -- (Observing, observeR', triesL, labeled) 68 | 69 | observing :: Ex.Observing 70 | observing = False -- True 71 | 72 | triesL :: InCoreTC t => [(String,RewriteH t)] -> RewriteH t 73 | triesL = Ex.triesL observing 74 | 75 | -- labeled :: InCoreTC t => (String, RewriteH t) -> RewriteH t 76 | -- labeled = Ex.labeled observing 77 | 78 | {-------------------------------------------------------------------- 79 | Reification 80 | --------------------------------------------------------------------} 81 | 82 | repName :: String -> HermitName 83 | repName = moduledName "Circat.Rep" 84 | 85 | lamName :: String -> HermitName 86 | lamName = moduledName "LambdaCCC.Lambda" 87 | 88 | -- ifName :: String -> HermitName 89 | -- ifName = moduledName "Circat.If" 90 | 91 | -- findIdE :: String -> TransformH a Id 92 | -- findIdE = findIdT . lamName 93 | 94 | appsE :: String -> [Type] -> [CoreExpr] -> TransformU CoreExpr 95 | appsE = apps' . lamName 96 | 97 | -- -- | Uncall a named function 98 | -- unCallE :: String -> TransformH CoreExpr [CoreExpr] 99 | -- unCallE = unCall . lamName 100 | 101 | -- | Uncall a named function 102 | unCallE1 :: String -> ReExpr 103 | unCallE1 = unCall1 . lamName 104 | 105 | -- A handy form for composition via <=< 106 | appsE1 :: String -> [Type] -> CoreExpr -> TransformU CoreExpr 107 | appsE1 str ts e = appsE str ts [e] 108 | 109 | -- callNameLam :: String -> TransformH CoreExpr (CoreExpr, [CoreExpr]) 110 | -- callNameLam = callNameT . lamName 111 | 112 | -- Some names 113 | 114 | evalS, reifyS :: String 115 | evalS = "evalEP" 116 | reifyS = "reifyEP" 117 | 118 | varPS, letS, varPatS :: String 119 | varPS = "varP#" 120 | letS = "lettP" 121 | varPatS = "varPat#" 122 | 123 | epS :: String 124 | epS = "EP" 125 | 126 | -- reify u --> u 127 | unReify :: ReExpr 128 | unReify = unCallE1 reifyS 129 | -- eval e --> e 130 | unEval :: ReExpr 131 | unEval = unCallE1 evalS 132 | 133 | -- reify (eval e) --> e 134 | reifyEval :: ReExpr 135 | reifyEval = unReify >>> unEval 136 | 137 | -- Generate a reify call. Fail on dictionaries. 138 | reifyOf :: CoreExpr -> TransformU CoreExpr 139 | reifyOf e = do guardMsg (not (isDictTy (exprType' e))) 140 | "reifyOf: Given a type expr." 141 | appsE reifyS [exprType' e] [e] 142 | 143 | -- reifyOf e = appsE reifyS [exprType' e] [e] 144 | 145 | evalOf :: CoreExpr -> TransformU CoreExpr 146 | evalOf e = appsE evalS [dropEP (exprType' e)] [e] 147 | 148 | dropEP :: Unop Type 149 | dropEP (TyConApp (unqualifiedName . tyConName -> name) [t]) = 150 | if name == epS then t 151 | else error ("dropEP: not an EP: " ++ show name) 152 | dropEP _ = error "dropEP: not a TyConApp" 153 | 154 | reifyR :: ReExpr 155 | reifyR = idR >>= reifyOf 156 | 157 | -- reify (u v) --> reify u `appP` reify v 158 | reifyApp :: ReExpr 159 | reifyApp = do App u v <- unReify 160 | Just (a,b) <- constT (return (splitFunTy_maybe (exprType' u))) 161 | -- guardMsg (not (isDictTy a)) "reifyApp: dictionary argument" 162 | u' <- reifyOf u 163 | v' <- reifyOf v 164 | appsE "appP" [b,a] [u', v'] -- note b,a 165 | 166 | -- reifyApps = 167 | -- unReify >>> callSplitT >>> arr (\ (f,ts,es) -> ((f,ts),es)) >>> reifyCall 168 | 169 | -- reifyCall :: TransformH ((CoreExpr,[Type]), [CoreExpr]) CoreExpr 170 | -- reifyCall = reifyR 171 | 172 | -- TODO: Use arr instead of (constT (return ...)) 173 | -- TODO: refactor so we unReify once and then try variations 174 | 175 | varEval :: Var -> TransformU CoreExpr 176 | varEval v = (evalOf <=< appsE1 varPS [varType v]) (varLitE v) 177 | 178 | varSubst :: [Var] -> TransformU (Unop CoreExpr) 179 | varSubst vs = do vs' <- mapM varEval vs 180 | return (subst (vs `zip` vs')) 181 | 182 | -- | reify (\ x -> e) --> lamv x' (reify (e[x := eval (var x')])) 183 | reifyLam :: ReExpr 184 | reifyLam = do Lam v e <- unReify 185 | guardMsg (not (isTyVar v)) "reifyLam: doesn't handle type lambda" 186 | sub <- varSubst [v] 187 | e' <- reifyOf (sub e) 188 | appsE "lamvP#" [varType v, exprType' e] [varLitE v,e'] 189 | 190 | -- reifyDef introduces foo_reified binding, which the letFloatLetR then moves up 191 | -- one level. Typically (always?) the "foo = eval foo_reified" definition gets 192 | -- inlined and then eliminated by the letElimR in reifyMisc. 193 | 194 | -- | Turn a monomorphic let into a beta-redex. 195 | reifyMonoLet :: ReExpr 196 | reifyMonoLet = 197 | unReify >>> 198 | do Let (NonRec v@(isForAllTy . varType -> False) rhs) body <- idR 199 | guardMsgM (worthLet rhs) "trivial let" 200 | rhsE <- reifyOf rhs 201 | sub <- varSubst [v] 202 | bodyE <- reifyOf (sub body) 203 | appsE "letvP#" [varType v, exprType' body] [varLitE v, rhsE,bodyE] 204 | 205 | -- Placeholder 206 | worthLet :: CoreExpr -> TransformU Bool 207 | worthLet _ = return True 208 | 209 | -- Simpler but can lead to loops. Maybe fix by following with reifyLam. 210 | -- 211 | -- reifyMonoLet = 212 | -- inReify $ 213 | -- do Let (NonRec v@(isForAllTy . varType -> False) rhs) body <- idR 214 | -- return (Lam v body `App` rhs) 215 | 216 | -- TODO: Perhaps combine reifyPolyLet and reifyMonoLet into reifyLet 217 | 218 | -- The simplifyE is for beta-reducing type applications. 219 | 220 | -- Rewrite inside of reify applications 221 | inReify :: Unop ReExpr 222 | inReify = reifyR <~ unReify 223 | 224 | #if 0 225 | reifyRuleNames :: [RuleName] 226 | reifyRuleNames = map (RuleName . ("reify/" ++)) 227 | [ "not","(&&)","(||)","xor","(+)","(*)","exl","exr","pair","inl","inr" 228 | , "if","()","false","true" 229 | ] 230 | 231 | -- ,"if-bool","if-pair" 232 | 233 | -- or: words "not (&&) (||) xor ..." 234 | 235 | -- TODO: Is there a way not to redundantly specify this rule list? 236 | -- Yes -- trust GHC to apply the rules later. 237 | -- Keep for now, to help us see that whether reify applications vanish. 238 | 239 | reifyRules :: ReExpr 240 | reifyRules = rulesR reifyRuleNames >>> cleanupUnfoldR 241 | 242 | #endif 243 | 244 | #if 0 245 | reifyCast :: ReExpr 246 | reifyCast = 247 | unReify >>> 248 | do Cast e co <- idR 249 | let Pair a b = coercionKind co 250 | re <- reifyOf e 251 | aTyp <- buildTypeableT' $* a 252 | bTyp <- buildTypeableT' $* b 253 | appsE "coerceEP" [a,b] [aTyp,bTyp,mkEqBox (toRep co),re] 254 | 255 | -- TODO: Probe whether we ever get nominal casts here. 256 | -- If so, reify differently, probably as a Core cast with mkNthCo. 257 | 258 | -- Convert a coercion to representational if not already 259 | toRep :: Unop Coercion 260 | toRep co | coercionRole co == Representational = co 261 | | otherwise = mkSubCo co 262 | 263 | #endif 264 | 265 | reifyIf :: ReExpr 266 | reifyIf = 267 | unReify >>> 268 | do (Var (fqVarName -> "LambdaCCC.Lambda.if'"),args@(length -> 2)) <- callT 269 | (\ f -> mkApps (Var f) args) <$> findIdT (lamName ("ifEP")) 270 | 271 | reifyBottom :: ReExpr 272 | reifyBottom = 273 | do App (Var (fqVarName -> "Circat.Rep.bottom")) (Type ty) <- unReify 274 | dict <- simpleDict ("Circat.Prim.CircuitBot") $* [ty] 275 | appsE "bottomEP" [ty] [dict] 276 | 277 | -- TODO: Combine reifyBottom with reifyStdMeths? 278 | 279 | -- TODO: factor out commonalities between reifyIf and reifyBottom. 280 | 281 | -- Translate methods to cat class and prim 282 | stdMeths :: M.Map String (String,String) 283 | stdMeths = M.fromList $ concatMap ops 284 | [ ( "GHC.Classes","Eq" 285 | , [("==","EqP"), ("/=","NeP")]) 286 | , ( "GHC.Classes","Ord" 287 | , [("<","LtP"),(">","GtP"),("<=","LeP"),(">=","GeP")]) 288 | , ( "GHC.Num", "Num" 289 | , [("negate","NegateP"),("+","AddP"),("-","SubP"),("*","MulP")]) 290 | , ( "GHC.Float", "Floating" 291 | , [("exp","ExpP"),("cos","CosP"),("sin","SinP")]) 292 | , ( "GHC.Real", "Fractional" 293 | , [("recip","RecipP"),("/","DivideP")]) 294 | -- FromIntegral has two parameters besides the category, 295 | -- and so needs special treatment. (This one doesn't work.) 296 | , ( "GHC.Real", "FromIntegral" 297 | , [("fromIntegral","FromIP")]) 298 | ] 299 | where 300 | op modu cls meth ctor = 301 | ( modu++"."++meth 302 | , ("Circat.Prim.Circuit"++cls, "Circat.Prim."++ctor)) 303 | ops (modu,cls,meths) = [op modu cls meth ctor | (meth,ctor) <- meths] 304 | 305 | -- Reify standard methods, given type and dictionary argument. 306 | -- We assume only a single type argument. 307 | reifyStdMeth :: ReExpr 308 | reifyStdMeth = 309 | unReify >>> 310 | do ty <- exprTypeT 311 | (Var (fqVarName -> flip M.lookup stdMeths -> Just (cls,prim)), tyArgs, moreArgs) <- callSplitT 312 | guardMsg (not (any isType moreArgs)) 313 | "reifyStdMeth: types among moreArgs" 314 | guardMsg (all (isDictTy . exprType) moreArgs) 315 | "reifyStdMeth: non-dict argument" 316 | catDict <- simpleDict (fromString cls) $* tyArgs 317 | primV <- findIdT (fromString prim) 318 | appsE1 "kPrimEP" [ty] (App (mkTyApps (Var primV) tyArgs) catDict) 319 | 320 | -- Reify an application of 'repr' or 'abst' to its type, dict, and coercion 321 | -- args (four in total), leaving the final expression argument for reifyApp. 322 | reifyRepMeth :: ReExpr 323 | reifyRepMeth = 324 | unReify >>> 325 | do (Var v,args@(length -> 4)) <- callT 326 | guardMsg (isRepMeth (fqVarName v)) "not a HasRep method" 327 | (\ f -> mkApps (Var f) args) <$> findIdT (lamName (uqVarName v ++ "EP")) 328 | 329 | isRepMeth :: String -> Bool 330 | isRepMeth = (`elem` repMethNames) . fromString 331 | 332 | repMethNames :: [HermitName] 333 | repMethNames = repName <$> ["repr","abst"] 334 | 335 | -- reify of case on 0-tuple or 2-tuple 336 | reifyTupCase :: ReExpr 337 | reifyTupCase = 338 | do Case scrut@(exprType' -> scrutT) wild bodyT [alt] <- unReify 339 | (patE,rhs) <- reifyAlt wild alt 340 | scrut' <- reifyOf scrut 341 | appsE letS [scrutT,bodyT] [patE,scrut',rhs] 342 | where 343 | -- Reify a case alternative, yielding a reified pattern and a reified 344 | -- alternative body (RHS). Only unit and pair patterns. Others are 345 | -- transformed away in the type-encode plugin. 346 | reifyAlt :: Var -> CoreAlt -> TransformU (CoreExpr,CoreExpr) 347 | reifyAlt wild (DataAlt ( isBoxedTupleTyCon . dataConTyCon -> True) 348 | , vars, rhs ) = 349 | do guardMsg (length vars `elem` [0,2]) 350 | "Only handles unit and pair patterns" 351 | vPats <- mapM varPatT vars 352 | sub <- varSubst (wild : vars) 353 | pat <- if null vars then 354 | appsE "UnitPat" [] [] 355 | else 356 | appsE ":$" (varType <$> vars) vPats 357 | pat' <- if wild `elemVarSet` localFreeIdsExpr rhs 358 | then -- WARNING: untested as of 2014-03-11 359 | appsE "asPat#" [varType wild] [varLitE wild,pat] 360 | else 361 | return pat 362 | rhs' <- reifyOf (sub rhs) 363 | return (pat', rhs') 364 | where 365 | varPatT :: Var -> TransformU CoreExpr 366 | varPatT v = appsE varPatS [varType v] [varLitE v] 367 | reifyAlt _ _ = fail "reifyAlt: Only handles pair patterns so far." 368 | 369 | reifyPrim :: ReExpr 370 | reifyPrim = 371 | unReify >>> 372 | do ty <- exprTypeT 373 | (Var (fqVarName -> flip M.lookup primMap -> Just nm), tyArgs, []) 374 | <- callSplitT 375 | primV <- findIdP nm 376 | appsE1 "kPrimEP" [ty] (mkApps (Var primV) (Type <$> tyArgs)) 377 | 378 | reifyLit :: ReExpr 379 | reifyLit = 380 | unReify >>> 381 | do ty <- exprTypeT 382 | guardMsg (isPrimitiveTy ty) "reifyLit: must have primitive type" 383 | void callDataConT 384 | e <- idR 385 | hasLitD <- simpleDict (primName "HasLit") $* [ty] 386 | appsE "kLit" [ty] [hasLitD,e] 387 | 388 | reifyDelay :: ReExpr 389 | reifyDelay = 390 | unReify >>> 391 | do (Var (fqVarName -> "Circat.Misc.delay"),[Type ty,s0]) <- callT 392 | showD <- simpleDict "GHC.Show.Show" $* [ty] 393 | genBusesD <- simpleDict "Circat.Circuit.GenBuses" $* [ty] 394 | primV <- findIdT "Circat.Prim.DelayP" 395 | appsE1 "kPrimEP" [ty `FunTy` ty] 396 | (mkApps (Var primV) [Type ty,genBusesD,showD,s0]) 397 | 398 | reifyLoop :: ReExpr 399 | reifyLoop = 400 | unReify >>> 401 | do (Var (fqVarName -> "Circat.Misc.loop"),tys@[_a,_b,s],[h]) <- callSplitT 402 | dict <- simpleDict (lamName "CircuitLoopKon") $* [s] 403 | h' <- reifyOf h 404 | appsE "loopEP" tys [dict,h'] 405 | 406 | -- Use in a final pass to generate helpful error messages for non-reified 407 | -- syntax. 408 | reifyOops :: ReExpr 409 | reifyOops = 410 | unReify >>> 411 | do ty <- exprTypeT 412 | str <- showPprT 413 | appsE "reifyOopsEP#" [ty] [Lit (mkMachString str)] 414 | 415 | miscL :: [(String,ReExpr)] 416 | miscL = [ ---- Special applications and so must come before reifyApp 417 | ("reifyEval" , reifyEval) 418 | -- , ("reifyRulesPrefix" , reifyRulesPrefix) 419 | -- , ("reifyRules" , reifyRules) 420 | , ("reifyRepMeth" , reifyRepMeth) 421 | , ("reifyStdMeth" , reifyStdMeth) 422 | , ("reifyIf" , reifyIf) 423 | , ("reifyBottom" , reifyBottom) 424 | , ("reifyDelay" , reifyDelay) 425 | , ("reifyLoop" , reifyLoop) 426 | , ("reifyLit" , reifyLit) 427 | ---- 428 | , ("reifyApp" , reifyApp) 429 | , ("reifyLam" , reifyLam) 430 | , ("reifyMonoLet" , reifyMonoLet) 431 | , ("reifyTupCase" , reifyTupCase) 432 | , ("reifyPrim" , reifyPrim) 433 | -- , ("reifyCast" , reifyCast) 434 | ] 435 | 436 | reifyMisc :: ReExpr 437 | reifyMisc = triesL miscL 438 | 439 | {-------------------------------------------------------------------- 440 | Primitives 441 | --------------------------------------------------------------------} 442 | 443 | findIdP :: String -> TransformH a Id 444 | findIdP = findIdT . primName 445 | 446 | primName :: String -> HermitName 447 | primName = moduledName "Circat.Prim" 448 | 449 | -- TODO: generalize primName, lamName, etc 450 | 451 | -- Map name to prim name and dictionary constraints 452 | primMap :: M.Map String String 453 | primMap = M.fromList 454 | [ ("GHC.Classes.not" , "NotP") 455 | , ("GHC.Classes.&&" , "AndP") 456 | , ("GHC.Classes.||" , "OrP") 457 | , ("Circat.Misc.xor" , "XorP") 458 | , ("GHC.Tuple.fst" , "ExlP") 459 | , ("GHC.Tuple.snd" , "ExrP") 460 | , ("Data.Either.Left" , "InlP") 461 | , ("Data.Either.Right" , "InrP") 462 | , ("GHC.Tuple.(,)" , "PairP") 463 | ] 464 | 465 | -- TODO: make primitives a map to expressions, to use during reification. Or 466 | -- maybe a transformation that succeeds only for primitives, since we'll have to 467 | -- look up IDs. 468 | 469 | isPrimitiveName :: String -> Bool 470 | isPrimitiveName name = 471 | name `M.member` primMap 472 | || name `M.member` stdMeths 473 | -- || isRepMeth name 474 | 475 | isPrimOrRepMeth :: Var -> [Type] -> Bool 476 | isPrimOrRepMeth (fqVarName -> name) tys = 477 | isRepMeth name || (isPrimitiveName name && all isPrimitiveTy tys) 478 | 479 | isPrimitiveOp :: Var -> Bool 480 | isPrimitiveOp (fqVarName -> name) = 481 | name `M.member` primMap 482 | || name `M.member` stdMeths 483 | -- || isRepMeth name 484 | 485 | -- isPrimitiveOp :: Var -> Type -> Bool 486 | -- isPrimitiveOp (fqVarName -> name) ty = 487 | -- name `M.member` primMap 488 | -- || (name `M.member` stdMeths && isPrimitiveTy ty) 489 | -- || isRepMeth name 490 | 491 | -- isPrimitiveOp :: Var -> [CoreExpr] -> Bool 492 | -- isPrimitiveOp (fqVarName -> name) args = 493 | -- name `M.member` primMap 494 | -- || (name `M.member` stdMeths && tyArg1 args) 495 | -- || isRepMeth name 496 | -- where 497 | -- tyArg1 [] = True -- test hack 498 | -- tyArg1 (Type ty : _) = isPrimitiveTy ty 499 | -- tyArg1 _ = False 500 | 501 | isPrimitiveTy :: Type -> Bool 502 | isPrimitiveTy ty = any ($ ty) [isUnitTy,isBoolTy,isIntTy,isDoubleTy] 503 | -------------------------------------------------------------------------------- /src/LambdaCCC/Unused/ReifyLambda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, GADTs, KindSignatures #-} 2 | {-# LANGUAGE ViewPatterns, PatternGuards, LambdaCase #-} 3 | {-# LANGUAGE FlexibleContexts, ConstraintKinds #-} 4 | {-# LANGUAGE MagicHash, CPP #-} 5 | {-# OPTIONS_GHC -Wall #-} 6 | 7 | -- TODO: Restore the following pragmas 8 | 9 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP 10 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TEMP 11 | 12 | ---------------------------------------------------------------------- 13 | -- | 14 | -- Module : LambdaCCC.ReifyLambda 15 | -- Copyright : (c) 2013 Tabula, Inc. 16 | -- LICENSE : BSD3 17 | -- 18 | -- Maintainer : conal@tabula.com 19 | -- Stability : experimental 20 | -- 21 | -- Reify a Core expression into GADT 22 | ---------------------------------------------------------------------- 23 | 24 | module LambdaCCC.ReifyLambda 25 | ( plugin 26 | ) where 27 | 28 | import Data.Functor ((<$>)) 29 | import Control.Applicative (Applicative(..)) 30 | -- import Control.Monad ((<=<),liftM2) 31 | import Control.Arrow (arr,(>>>)) 32 | import Data.List (intercalate) 33 | import qualified Data.Map as M 34 | import qualified Data.Set as S 35 | import Data.Maybe (fromMaybe) 36 | import Text.Printf (printf) 37 | 38 | -- import qualified Language.Haskell.TH as TH (Name) -- ,mkName 39 | -- import qualified Language.Haskell.TH.Syntax as TH (showName) 40 | 41 | -- GHC API 42 | -- import PrelNames (unitTyConKey,boolTyConKey,intTyConKey) 43 | 44 | import qualified Language.KURE.Translate as Kure 45 | import HERMIT.Monad (HermitM,newIdH) 46 | import HERMIT.Context 47 | (ReadBindings(..),hermitBindings,HermitBinding(..),HermitBindingSite(..) 48 | ,lookupHermitBinding,boundIn,BoundVars,HasGlobalRdrEnv(..)) -- ,AddBindings 49 | import HERMIT.Core (Crumb(..),localFreeIdsExpr) 50 | import HERMIT.External 51 | import HERMIT.GHC hiding (mkStringExpr) 52 | import HERMIT.Kure hiding (apply) 53 | import HERMIT.Plugin 54 | 55 | -- Note: All of the Dictionary submodules are now re-exported by HERMIT.Dictionary, 56 | -- so if you prefer you could import all these via that module, rather than seperately. 57 | import HERMIT.Dictionary.AlphaConversion (unshadowR) 58 | import HERMIT.Dictionary.Common 59 | import HERMIT.Dictionary.Composite (simplifyR) 60 | import HERMIT.Dictionary.Debug (observeR) 61 | import HERMIT.Dictionary.Rules (rulesR) -- ruleR, 62 | import HERMIT.Dictionary.Inline (inlineNameR) -- , inlineNamesR 63 | import HERMIT.Dictionary.Local (letIntroR,letFloatArgR,letFloatTopR) 64 | import HERMIT.Dictionary.Navigation (rhsOfT,parentOfT,bindingGroupOfT) 65 | -- import HERMIT.Dictionary.Composite (simplifyR) 66 | import HERMIT.Dictionary.Unfold (cleanupUnfoldR) -- unfoldNameR, 67 | 68 | import LambdaCCC.Misc (Unop) -- ,Binop 69 | -- import qualified LambdaCCC.Ty as T 70 | -- import qualified Circat.Prim as P 71 | -- import qualified LambdaCCC.Lambda as E 72 | -- import LambdaCCC.MkStringExpr (mkStringExpr) 73 | 74 | {-------------------------------------------------------------------- 75 | Core utilities 76 | --------------------------------------------------------------------} 77 | 78 | apps :: Id -> [Type] -> [CoreExpr] -> CoreExpr 79 | apps f ts es 80 | | tyArity f /= length ts = 81 | error $ printf "apps: Id %s wants %d type arguments but got %d." 82 | (var2String f) arity ntys 83 | | otherwise = mkCoreApps (varToCoreExpr f) (map Type ts ++ es) 84 | where 85 | arity = tyArity f 86 | ntys = length ts 87 | 88 | tyArity :: Id -> Int 89 | tyArity = length . fst . splitForAllTys . varType 90 | 91 | {- 92 | listToPair :: [a] -> Maybe (a,a) 93 | listToPair [a,b] = Just (a,b) 94 | listToPair _ = Nothing 95 | 96 | unTuple :: CoreExpr -> Maybe [CoreExpr] 97 | unTuple expr@(App {}) 98 | | (Var f, dropWhile isTypeArg -> valArgs) <- collectArgs expr 99 | , Just dc <- isDataConWorkId_maybe f 100 | , isTupleTyCon (dataConTyCon dc) && (valArgs `lengthIs` idArity f) 101 | = Just valArgs 102 | unTuple _ = Nothing 103 | 104 | unPair :: CoreExpr -> Maybe (CoreExpr,CoreExpr) 105 | unPair = listToPair <=< unTuple 106 | -} 107 | 108 | -- TODO: Maybe remove unPair and unPairTy, since it's just as easy to use 109 | -- unTuple and pattern-match against Just [a,b]. 110 | 111 | {- 112 | -- Unsafe way to ppr in pure code. 113 | tr :: Outputable a => a -> a 114 | tr x = trace ("tr: " ++ pretty x) x 115 | 116 | pretty :: Outputable a => a -> String 117 | pretty = showPpr tracingDynFlags 118 | 119 | pretties :: Outputable a => [a] -> String 120 | pretties = intercalate "," . map pretty 121 | -} 122 | 123 | -- | Variant of GHC's 'collectArgs' 124 | collectTypeArgs :: CoreExpr -> ([Type], CoreExpr) 125 | collectTypeArgs expr = go [] expr 126 | where 127 | go ts (App f (Type t)) = go (t:ts) f 128 | go ts e = (reverse ts, e) 129 | 130 | collectForalls :: Type -> ([Var], Type) 131 | collectForalls ty = go [] ty 132 | where 133 | go vs (ForAllTy v t') = go (v:vs) t' 134 | go vs t = (reverse vs, t) 135 | 136 | -- TODO: Rewrite collectTypeArgs and collectForalls as unfolds and refactor. 137 | 138 | #if 0 139 | 140 | unTupleTy :: Type -> Maybe [Type] 141 | unTupleTy (TyConApp tc tys) 142 | | isTupleTyCon tc && tyConArity tc == length tys = Just tys 143 | unTupleTy _ = Nothing 144 | 145 | -- unPairTy :: Type -> Maybe (Type,Type) 146 | -- unPairTy = listToPair <=< unTupleTy 147 | 148 | -- For a given tycon, drop it from a unary type application. Error otherwise. 149 | -- WARNING: I'm not yet checking for a tycon match. TODO: check. 150 | dropTyApp1 :: TH.Name -> Type -> Type 151 | dropTyApp1 _ (TyConApp _ [t]) = t 152 | dropTyApp1 _ _ = error "dropTyApp1: not a unary TyConApp" 153 | 154 | #endif 155 | 156 | -- Substitute a new subexpression for a variable in an expression 157 | subst1 :: (Id,CoreExpr) -> CoreExpr -> CoreExpr 158 | subst1 (v,new) = substExpr (error "subst1: no SDoc") 159 | (extendIdSubst emptySubst v new) 160 | 161 | {-------------------------------------------------------------------- 162 | KURE utilities 163 | --------------------------------------------------------------------} 164 | 165 | -- -- | Transformation while focused on a path 166 | -- pathIn :: (Eq crumb, ReadPath c crumb, MonadCatch m, Walker c b) => 167 | -- Translate c m b (Path crumb) -> Unop (Rewrite c m b) 168 | -- pathIn mkP f = mkP >>= flip pathR f 169 | 170 | -- | Transformation while focused on a snoc path 171 | snocPathIn :: ( Eq crumb, Functor m, ReadPath c crumb 172 | , MonadCatch m, Walker c b ) => 173 | Translate c m b (SnocPath crumb) -> Unop (Rewrite c m b) 174 | snocPathIn mkP r = mkP >>= flip localPathR r 175 | 176 | {-------------------------------------------------------------------- 177 | HERMIT utilities 178 | --------------------------------------------------------------------} 179 | 180 | -- Next two from Andy G: 181 | 182 | -- | Lookup the name in the context first, then, failing that, in GHC's global 183 | -- reader environment. 184 | findTyConT :: ( BoundVars c, HasGlobalRdrEnv c, HasDynFlags m 185 | , MonadThings m, MonadCatch m) => 186 | String -> Translate c m a TyCon 187 | findTyConT nm = prefixFailMsg ("Cannot resolve name " ++ nm ++ ", ") $ 188 | contextonlyT (findTyConMG nm) 189 | 190 | findTyConMG :: (BoundVars c, HasGlobalRdrEnv c, HasDynFlags m, MonadThings m) => String -> c -> m TyCon 191 | findTyConMG nm c = 192 | case filter isTyConName $ findNamesFromString (hermitGlobalRdrEnv c) nm of 193 | [n] -> lookupTyCon n 194 | ns -> do dynFlags <- getDynFlags 195 | fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns) 196 | 197 | #if 0 198 | -- | Translate a pair expression. 199 | pairT :: (Monad m, ExtendPath c Crumb) => 200 | Translate c m CoreExpr a -> Translate c m CoreExpr b 201 | -> (Type -> Type -> a -> b -> z) -> Translate c m CoreExpr z 202 | pairT tu tv f = translate $ \ c -> 203 | \ case (unPair -> Just (u,v)) -> 204 | liftM2 (f (exprType u) (exprType v)) 205 | (Kure.apply tu (c @@ App_Fun @@ App_Arg) u) 206 | (Kure.apply tv (c @@ App_Arg) v) 207 | _ -> fail "not a pair node." 208 | 209 | -- | Translate an n-ary type-instantiation of a variable, where n >= 0. 210 | appVTysT :: (ExtendPath c Crumb, Monad m) => 211 | Translate c m Var a -> (a -> [Type] -> b) -> Translate c m CoreExpr b 212 | appVTysT tv h = translate $ \c -> 213 | \ case (collectTypeArgs -> (ts, Var v)) -> 214 | liftM2 h (Kure.apply tv (applyN (length ts) (@@ App_Fun) c) v) 215 | (return ts) 216 | _ -> fail "not an application of a variable to types." 217 | where 218 | applyN :: Int -> (a -> a) -> a -> a 219 | applyN n f a = foldr ($) a (replicate n f) 220 | #endif 221 | 222 | defR :: RewriteH Id -> RewriteH CoreExpr -> RewriteH Core 223 | defR rewI rewE = prunetdR ( promoteDefR (defAllR rewI rewE) 224 | <+ promoteBindR (nonRecAllR rewI rewE) ) 225 | 226 | rhsR :: RewriteH CoreExpr -> RewriteH Core 227 | rhsR = defR idR 228 | 229 | -- unfoldNames :: [TH.Name] -> RewriteH CoreExpr 230 | -- unfoldNames nms = catchesM (unfoldNameR <$> nms) -- >>> cleanupUnfoldR 231 | 232 | -- The set of variables in a HERMIT context 233 | isLocal :: ReadBindings c => c -> (Var -> Bool) 234 | isLocal = flip boundIn 235 | 236 | -- | Extract just the lambda-bound variables in a HERMIT context 237 | isLocalT :: (ReadBindings c, Applicative m) => Translate c m a (Var -> Bool) 238 | isLocalT = contextonlyT (pure . isLocal) 239 | 240 | -- topLevelBindsR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => 241 | -- Rewrite c m CoreBind -> Rewrite c m ModGuts 242 | -- topLevelBindsR r = modGutsR progBindsR 243 | -- where 244 | -- progBindsR = progConsAnyR r progBindsR 245 | 246 | -- topLevelBindsR r = modGutsR (fix (progConsAnyR r)) 247 | 248 | type InCoreTC t = Injection t CoreTC 249 | 250 | observing :: Bool 251 | observing = False 252 | 253 | observeR' :: InCoreTC t => String -> RewriteH t 254 | observeR' | observing = observeR 255 | | otherwise = const idR 256 | 257 | tries :: (InCoreTC a, InCoreTC t) => [(String,TranslateH a t)] -> TranslateH a t 258 | tries = foldr (<+) (observeR "Unhandled" >>> fail "unhandled") 259 | . map (uncurry labeled) 260 | 261 | labeled :: InCoreTC t => String -> Unop (TranslateH a t) 262 | labeled label = (>>> observeR' label) 263 | 264 | {-------------------------------------------------------------------- 265 | Reification 266 | --------------------------------------------------------------------} 267 | 268 | #if 0 269 | 270 | type ReType = TranslateH Type CoreExpr 271 | 272 | -- | Translate a Core type t into a core expression that evaluates to a Ty t. 273 | reifyType :: ReType 274 | reifyType = 275 | do funTId <- findIdT '(T.:=>) 276 | pairTId <- findIdT '(T.:*) 277 | unitTId <- findIdT 'T.Unit 278 | intTID <- findIdT 'T.Int 279 | boolTID <- findIdT 'T.Bool 280 | let simples :: M.Map Unique Id 281 | simples = M.fromList [ (unitTyConKey,unitTId),(boolTyConKey,boolTID) 282 | , (intTyConKey,intTID) ] 283 | simpleTId :: TyCon -> Maybe Id 284 | simpleTId = flip M.lookup simples . getUnique 285 | rew :: ReType 286 | rew = tries [ ("TSimple",rTSimple),("TPair",rTPair) 287 | , ("TFun",rTFun), ("TSynonym",rTSyn) ] 288 | rTSimple, rTPair, rTFun, rTSyn :: ReType 289 | rTSimple = do TyConApp (simpleTId -> Just tid) [] <- idR 290 | return (apps tid [] []) 291 | rTPair = do Just [_,_] <- unTupleTy <$> idR 292 | tyConAppT (pure ()) (const rew) $ \ () [a',b'] -> 293 | tyOp2 pairTId a' b' 294 | rTFun = funTyT rew rew $ tyOp2 funTId 295 | rTSyn = expandSyn >>> rew 296 | expandSyn :: RewriteH Type 297 | expandSyn = do Just t <- tcView <$> idR 298 | return t 299 | tyOp2 :: Id -> Binop CoreExpr 300 | tyOp2 tid a' b' = apps tid [tyTy a',tyTy b'] [a',b'] 301 | rew 302 | 303 | -- TODO: Look up the ids only once in reifyExpr, not every time 'reifyType' is called. 304 | 305 | -- tyConAppT :: (ExtendPath c Crumb, Monad m) => 306 | -- Translate c m TyCon a1 -> (Int -> Translate c m KindOrType a2) 307 | -- -> (a1 -> [a2] -> b) -> Translate c m Type b 308 | 309 | -- The type parameter a of an expression of type Ty a. 310 | tyTy :: CoreExpr -> Type 311 | tyTy = dropTyApp1 ''T.Ty . exprType 312 | 313 | #endif 314 | 315 | type ReExpr = RewriteH CoreExpr 316 | 317 | lamName :: Unop String 318 | lamName = ("LambdaCCC.Lambda." ++) 319 | 320 | findIdE :: String -> TranslateH a Id 321 | findIdE = findIdT . lamName 322 | 323 | findTyConE :: String -> TranslateH a TyCon 324 | findTyConE = findTyConT . lamName 325 | 326 | reifyExpr :: ReExpr 327 | reifyExpr = 328 | do varId# <- findIdE "varP#" -- "var#" 329 | appId <- findIdE "appP" -- "(@^)" 330 | lamvId# <- findIdE "lamvP#" -- "lamv#" 331 | -- casevId# <- findIdE "casevP#" -- "casev#" 332 | evalId <- findIdE "evalEP" -- "evalEP" 333 | reifyId# <- findIdE "reifyEP#" -- "reifyE#" 334 | letId <- findIdE "lettP" -- "lett" 335 | varPatId# <- findIdE "varPat#" 336 | pairPatId <- findIdE ":#" 337 | asPatId# <- findIdE "asPat#" 338 | -- primId# <- findIdT ''P.Prim -- not found! :/ 339 | -- testEId <- findIdT "EP" 340 | epTC <- findTyConE "EP" 341 | let reifyRhs :: RewriteH CoreExpr 342 | reifyRhs = 343 | do ty <- arr exprType 344 | let (tyVars,ty') = collectForalls ty 345 | mkEval (collectTyBinders -> (tyVars',body)) = 346 | if tyVars == tyVars' then 347 | mkLams tyVars (apps evalId [ty'] [body]) 348 | else 349 | error $ "mkEval: type variable mismatch: " 350 | ++ show (uqVarName <$> tyVars, uqVarName <$> tyVars') 351 | -- If I ever get the type variable mismatch error, take a 352 | -- different approach, extracting the type of e' and 353 | -- dropping the EP. 354 | mkEval <$> rew 355 | where 356 | eTy e = TyConApp epTC [e] 357 | eVar :: Var -> HermitM Var 358 | eVar v = newIdH (uqVarName v ++ "E") (eTy (varType v)) 359 | rew :: ReExpr 360 | rew = tries [ ("Eval" ,rEval) 361 | , ("Reify",rReify) 362 | , ("AppT" ,rAppT) 363 | , ("Var#" ,rVar#) 364 | , ("LamT" ,rLamT) 365 | , ("App" ,rApp) 366 | , ("Lam#" ,rLam#) 367 | , ("Let" ,rLet) 368 | , ("Case" ,rCase) 369 | ] 370 | where 371 | -- rVar# = do local <- isLocalT 372 | -- varT $ 373 | -- do v <- idR 374 | -- if local v then 375 | -- return $ apps varId# [varType v] [varLitE v] 376 | -- else 377 | -- fail "rVar: not a lambda-bound variable" 378 | 379 | -- reify (eval e) == e 380 | rEval = do (_evalE, [Type _, e]) <- callNameLam "evalEP" 381 | return e 382 | -- Reify non-local variables and their polymorphic instantiations. 383 | rReify = do local <- isLocalT 384 | e@(collectTypeArgs -> (_, Var v)) <- idR 385 | if local v then 386 | fail "rReify: lambda-bound variable" 387 | else 388 | return $ apps reifyId# [exprType e] [e,varLitE v] 389 | rAppT = do App _ (Type _) <- idR -- Type applications 390 | appT rew idR (arr App) 391 | rLamT = do Lam (isTyVar -> True) _ <- idR 392 | lamT idR rew (arr Lam) 393 | rApp = do App (exprType -> funTy) _ <- idR 394 | appT rew rew $ arr $ \ u' v' -> 395 | let (a,b) = splitFunTy funTy in 396 | apps appId [b,a] [u', v'] -- note b,a 397 | #if 0 398 | rLam# = translate $ \ c -> \case 399 | Lam v@(varType -> vty) e -> 400 | do eV <- eVar v 401 | e' <- Kure.apply rew (c @@ Lam_Body) $ 402 | subst1 (v, apps evalId [vty] [ 403 | apps varId# [vty] [varLitE eV]]) e 404 | return (apps lamvId# [vty, exprType e] [varLitE eV,e']) 405 | _ -> fail "not a lambda." 406 | #else 407 | rLam# = do Lam (varType -> vty) (exprType -> bodyTy) <- idR 408 | lamT idR rew $ arr $ \ v e' -> 409 | apps lamvId# [vty, bodyTy] [varLitE v,e'] 410 | #endif 411 | -- TODO: Eliminate rVar# 412 | rVar# :: ReExpr 413 | rVar# = do local <- isLocalT 414 | Var v <- idR 415 | if local v then 416 | return $ apps varId# [varType v] [varLitE v] 417 | else 418 | fail "rVar: not a lambda-bound variable" 419 | #if 0 420 | rLet = do -- only NonRec for now 421 | Let (NonRec (varType -> patTy) _) (exprType -> bodyTy) <- idR 422 | letT reifyBind rew $ \ (patE,rhs') body' -> 423 | apps letId [patTy,bodyTy] [patE,rhs',body'] 424 | #else 425 | rLet = toRedex >>> rew 426 | where 427 | toRedex = do Let (NonRec v rhs) body <- idR 428 | return (Lam v body `App` rhs) 429 | 430 | #endif 431 | -- For now, handling only single-branch case expressions containing 432 | -- pair patterns. The result will be to form nested lambda patterns in 433 | -- a beta redex. 434 | rCase = do Case (exprType -> scrutT) wild _ [_] <- idR 435 | _ <- observeR' "Reifying case" 436 | caseT rew idR idR (const (reifyAlt wild)) $ 437 | \ scrutE' _ bodyT [(patE,rhs)] -> 438 | apps letId [scrutT,bodyT] [patE,scrutE',rhs] 439 | -- Reify a case alternative, yielding a reified pattern and a reified 440 | -- alternative body (RHS). 441 | reifyAlt :: Var -> TranslateH CoreAlt (CoreExpr,CoreExpr) 442 | reifyAlt wild = 443 | do -- Only pair patterns for now 444 | _ <- observeR' "Reifying case alternative" 445 | (DataAlt (isTupleTyCon.dataConTyCon -> True), vars@[_,_], _) <- idR 446 | vPats <- mapM (applyInContextT (labeled "varPatT" varPatT#)) vars 447 | altT idR (const idR) rew $ \ _ _ rhs' -> 448 | let pat = apps pairPatId (varType <$> vars) vPats 449 | pat' | wild `elemVarSet` localFreeIdsExpr rhs' 450 | = -- WARNING: untested as of 2013-07-22 451 | apps asPatId# [varType wild] [varLitE wild,pat] 452 | | otherwise = pat 453 | in 454 | (pat', rhs') 455 | varPatT# :: TranslateH Var CoreExpr 456 | varPatT# = do v <- idR 457 | return $ apps varPatId# [varType v] [varLitE v] 458 | -- Reify a Core binding into a reified pattern and expression. 459 | -- Only handle NonRec bindings for now. 460 | reifyBind :: TranslateH CoreBind (CoreExpr,CoreExpr) 461 | reifyBind = nonRecT varPatT# rew (,) 462 | -- TODO: Literals 463 | do _ <- observeR' "Reifying expression" 464 | reifyRhs 465 | 466 | reifyExprC :: RewriteH Core 467 | reifyExprC = tryR unshadowR >>> promoteExprR reifyExpr 468 | 469 | -- unshadow since we extract variable names without the uniques 470 | 471 | {- 472 | letT :: (ExtendPath c Crumb, AddBindings c, Monad m) 473 | => Translate c m CoreBind a1 474 | -> Translate c m CoreExpr a2 475 | -> (a1 -> a2 -> b) 476 | -> Translate c m CoreExpr b 477 | 478 | caseT :: (ExtendPath c Crumb, AddBindings c, Monad m) 479 | => Translate c m CoreExpr e 480 | -> Translate c m Id w 481 | -> Translate c m Type ty 482 | -> (Int -> Translate c m CoreAlt alt) 483 | -> (e -> w -> ty -> [alt] -> b) 484 | -> Translate c m CoreExpr b 485 | 486 | altT :: (ExtendPath c Crumb, AddBindings c, Monad m) 487 | => Translate c m AltCon a1 488 | -> (Int -> Translate c m Var a2) 489 | -> Translate c m CoreExpr a3 490 | -> (a1 -> [a2] -> a3 -> b) 491 | -> Translate c m CoreAlt b 492 | -} 493 | 494 | -- mkVarName :: MonadThings m => Translate c m Var (CoreExpr,Type) 495 | -- mkVarName = contextfreeT (mkStringExpr . uqName . varName) &&& arr varType 496 | 497 | varLitE :: Var -> CoreExpr 498 | varLitE = Lit . mkMachString . uqVarName 499 | 500 | uqVarName :: Var -> String 501 | uqVarName = uqName . varName 502 | 503 | anybuER :: (MonadCatch m, Walker c g, ExtendPath c Crumb, Injection CoreExpr g) => 504 | Rewrite c m CoreExpr -> Rewrite c m g 505 | anybuER r = anybuR (promoteExprR r) 506 | 507 | -- anytdER :: (MonadCatch m, Walker c g, ExtendPath c Crumb, Injection CoreExpr g) => 508 | -- Rewrite c m CoreExpr -> Rewrite c m g 509 | -- anytdER r = anytdR (promoteExprR r) 510 | 511 | tryRulesBU :: [String] -> RewriteH Core 512 | tryRulesBU = tryR . anybuER . rulesR 513 | 514 | reifyRules :: RewriteH Core 515 | reifyRules = tryRulesBU $ map ("reify/" ++) 516 | ["not","(&&)","(||)","xor","(+)","exl","exr","pair","inl","inr","if","false","true"] 517 | 518 | -- or: words $ "not (&&) (||) xor ..." 519 | 520 | -- TODO: Is there a way not to redundantly specify this rule list? 521 | -- Yes -- trust GHC to apply the rules later. 522 | 523 | reifyDef :: RewriteH Core 524 | reifyDef = rhsR reifyExpr 525 | 526 | callNameLam :: String -> TranslateH CoreExpr (CoreExpr, [CoreExpr]) 527 | callNameLam = callNameT . lamName 528 | 529 | -- Unused 530 | reifyEval :: ReExpr 531 | reifyEval = reifyArg >>> evalArg 532 | where 533 | reifyArg = do (_reifyE, [Type _, arg, _str]) <- callNameLam "reifyEP" 534 | return arg 535 | evalArg = do (_evalE, [Type _, body]) <- callNameLam "evalEP" 536 | return body 537 | 538 | -- TODO: reifyEval replaced with tryRulesBU ["reify'/eval","eval/reify'"], and 539 | -- even those rules are no longer invoked explicitly. 540 | 541 | inlineCleanup :: String -> RewriteH Core 542 | inlineCleanup nm = tryR $ anybuER (inlineNameR nm) >>> anybuER cleanupUnfoldR 543 | 544 | -- inlineNamesTD :: [String] -> RewriteH Core 545 | -- inlineNamesTD nms = anytdER (inlineNamesR nms) 546 | 547 | -- #define FactorReified 548 | 549 | reifyNamed :: String -> RewriteH Core 550 | reifyNamed nm = snocPathIn (rhsOfT cmpNm) 551 | ( inlineCleanup (lamName "ifThenElse") 552 | -- >>> (tryR $ anytdER $ rule "if/pair") 553 | >>> reifyExprC 554 | >>> reifyRules 555 | #ifdef FactorReified 556 | >>> pathR [App_Arg] (promoteExprR (letIntroR (nm ++ "_reified"))) 557 | >>> promoteExprR letFloatArgR 558 | #endif 559 | ) 560 | #ifdef FactorReified 561 | >>> snocPathIn (extractT $ parentOfT $ bindingGroupOfT $ cmpNm) 562 | (promoteProgR letFloatTopR) 563 | #endif 564 | >>> inlineCleanup nm 565 | -- I don't know why the following is needed, considering the INLINE 566 | >>> inlineCleanup (lamName "reifyEP#") 567 | -- >>> tryR (anybuER (promoteExprR reifyEval)) 568 | -- >>> tryRulesBU ["reifyE/evalE","evalE/reifyE"] 569 | -- >>> tryRulesBU ["reifyEP/evalEP"] 570 | >>> tryR simplifyR -- For the rule applications at least 571 | where 572 | cmpNm = cmpString2Var nm 573 | 574 | -- I don't know why I need both cleanupUnfoldR and simplifyR. 575 | 576 | -- Note: I inline reifyE to its reifyE definition and then simplify 577 | -- reifyE/evalE, rather than simplifying reifyE/evalE. With this choice, I can 578 | -- also reifyE/evalE combinations that come from reifyE in source code and ones 579 | -- that reifyExpr inserts. 580 | 581 | {-------------------------------------------------------------------- 582 | Plugin 583 | --------------------------------------------------------------------} 584 | 585 | plugin :: Plugin 586 | plugin = hermitPlugin (phase 0 . interactive externals) 587 | 588 | externals :: [External] 589 | externals = 590 | [ external "reify-expr" 591 | (promoteExprR reifyExpr :: RewriteH Core) 592 | ["Reify a Core expression into a GADT construction"] 593 | , external "reify-rules" 594 | (reifyRules :: RewriteH Core) 595 | ["convert some non-local vars to consts"] 596 | , external "inline-cleanup" 597 | (inlineCleanup :: String -> RewriteH Core) 598 | ["inline a named definition, and clean-up beta-redexes"] 599 | , external "reify-def" 600 | (reifyDef :: RewriteH Core) 601 | ["reify for definitions"] 602 | , external "reify-expr-cleanup" 603 | (promoteExprR reifyExpr >>> reifyRules :: RewriteH Core) 604 | ["reify-core and cleanup for expressions"] 605 | , external "reify-def-cleanup" 606 | (reifyDef >>> reifyRules :: RewriteH Core) 607 | ["reify-core and cleanup for definitions"] 608 | , external "reify-named" 609 | (reifyNamed :: String -> RewriteH Core) 610 | ["reify via name"] 611 | -- , external "reify-tops" 612 | -- (reifyTops :: RewriteH ModGuts) 613 | -- ["reify via name"] 614 | , external "reify-eval" 615 | (anybuER (promoteExprR reifyEval) :: RewriteH Core) 616 | ["simplify reifyE composed with evalE"] 617 | ] 618 | --------------------------------------------------------------------------------