├── .travis.yml ├── Setup.hs ├── AUTHORS.txt ├── .gitignore ├── tests ├── Makefile └── NonTerminating.hs ├── Strict ├── Annotation.hs ├── Plugin.hs └── Pass.lhs ├── README.md ├── strict-ghc-plugin.cabal └── LICENSE.txt /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain -------------------------------------------------------------------------------- /AUTHORS.txt: -------------------------------------------------------------------------------- 1 | Original author: Max Bolingbroke 2 | Maintainer: Austin Seipp 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _darcs 2 | *.o 3 | *.hi 4 | *~ 5 | dist* 6 | tests/*.o 7 | tests/*.hi 8 | tests/Traced 9 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ghc -O2 -fforce-recomp -fplugin Strict.Plugin NonTerminating 3 | clean: 4 | rm -f *.o *.hi NonTerminating 5 | -------------------------------------------------------------------------------- /tests/NonTerminating.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main ( main ) where 3 | import Strict.Annotation 4 | 5 | {-# ANN foreverFrom Strictify #-} 6 | foreverFrom :: Int -> [Int] 7 | foreverFrom n = n : foreverFrom (n + 1) 8 | 9 | main :: IO () 10 | main = do 11 | let xs = foreverFrom 0 12 | print (take 10 xs) 13 | -------------------------------------------------------------------------------- /Strict/Annotation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Strict.Annotation where 3 | import Data.Data 4 | 5 | -- | Programs which want to 'strictify' their functions should annotate them with the following 6 | -- datatype 7 | -- TODO: move this into a separate package perhaps? 8 | data Strictify = Strictify deriving (Typeable, Data) 9 | -------------------------------------------------------------------------------- /Strict/Plugin.hs: -------------------------------------------------------------------------------- 1 | module Strict.Plugin 2 | ( plugin -- :: Plugin 3 | ) where 4 | 5 | import Strict.Pass (strictifyProgram) 6 | import GhcPlugins 7 | 8 | plugin :: Plugin 9 | plugin = defaultPlugin { 10 | installCoreToDos = install 11 | } 12 | 13 | install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] 14 | install _ todos = do 15 | reinitializeGlobals 16 | return $ CoreDoPluginPass "Strictify" strictifyProgram : todos -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # GHC plugin for making functions strict. 2 | 3 | This plugin gives an example of defining a compiler plugin for 4 | GHC. You mark functions with the `Strictify` annotation and GHC makes 5 | the function strict (by recursively expanding non-recursive let 6 | bindings into case bindings.) 7 | 8 | [travis-ci.org](http://travis-ci.org) results: [![Build Status](https://secure.travis-ci.org/thoughtpolice/strict-ghc-plugin.png?branch=master)](http://travis-ci.org/thoughtpolice/strict-ghc-plugin) 9 | 10 | [Homepage][main page]. 11 | 12 | # Installation 13 | 14 | Install the latest version of the plugin from Hackage (requires GHC 7.4.1): 15 | 16 | $ cabal install strict-ghc-plugin 17 | 18 | # Join in 19 | 20 | File bugs in the GitHub [issue tracker][]. 21 | 22 | Master [git repository][gh]: 23 | 24 | * `git clone https://github.com/thoughtpolice/strict-ghc-plugin.git` 25 | 26 | There's also a [BitBucket mirror][bb]: 27 | 28 | * `git clone https://bitbucket.org/thoughtpolice/strict-ghc-plugin.git` 29 | 30 | # Authors 31 | 32 | See [AUTHORS.txt](https://raw.github.com/thoughtpolice/strict-ghc-plugin/master/AUTHORS.txt). 33 | 34 | # License 35 | 36 | BSD3. See `LICENSE.txt` for terms of copyright and redistribution. 37 | 38 | [main page]: http://thoughtpolice.github.com/strict-ghc-plugin 39 | [issue tracker]: http://github.com/thoughtpolice/strict-ghc-plugin/issues 40 | [gh]: http://github.com/thoughtpolice/strict-ghc-plugin 41 | [bb]: http://bitbucket.org/thoughtpolice/strict-ghc-plugin 42 | -------------------------------------------------------------------------------- /strict-ghc-plugin.cabal: -------------------------------------------------------------------------------- 1 | name: strict-ghc-plugin 2 | version: 0.1.1 3 | synopsis: Compiler plugin for making Haskell strict 4 | description: 5 | This plugin gives an example of defining a compiler plugin for 6 | GHC. You mark functions with the `Strictify` annotation and GHC 7 | makes the function strict (by recursively expanding non-recursive 8 | let bindings into case bindings.) 9 | homepage: http://thoughtpolice.github.com/strict-ghc-plugin 10 | bug-reports: http://github.com/thoughtpolice/strict-ghc-plugin/issues 11 | license: BSD3 12 | license-file: LICENSE.txt 13 | copyright: Copyright (c) the GHC authors 14 | author: The GHC authors 15 | maintainer: Austin Seipp 16 | category: Compiler Plugin 17 | build-type: Simple 18 | cabal-version: >=1.10 19 | tested-with: GHC == 7.4.1 20 | 21 | extra-source-files: 22 | AUTHORS.txt README.md 23 | tests/*.hs tests/Makefile 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/thoughtpolice/strict-ghc-plugin.git 28 | 29 | library 30 | exposed-modules: 31 | Strict.Plugin 32 | Strict.Annotation 33 | other-modules: 34 | Strict.Pass 35 | build-depends: 36 | base < 5, 37 | ghc >= 7.4, 38 | syb 39 | 40 | ghc-options: -Wall -O2 -funbox-strict-fields 41 | -fwarn-tabs 42 | default-extensions: CPP 43 | default-language: Haskell2010 44 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | The Glasgow Haskell Compiler License 2 | 3 | Copyright 2002, The University Court of the University of Glasgow. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | - Redistributions of source code must retain the above copyright notice, 10 | this list of conditions and the following disclaimer. 11 | 12 | - Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | - Neither name of the University nor the names of its contributors may be 17 | used to endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 21 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 22 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 23 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 25 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 27 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 31 | DAMAGE. 32 | -------------------------------------------------------------------------------- /Strict/Pass.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | {-# LANGUAGE PatternGuards #-} 3 | 4 | module Strict.Pass (strictifyProgram) where 5 | 6 | import GhcPlugins 7 | 8 | import Control.Monad 9 | import Data.Generics 10 | 11 | import Strict.Annotation 12 | 13 | \end{code} 14 | Strictification of a program based on annotations. 15 | \begin{code} 16 | 17 | strictifyProgram :: ModGuts -> CoreM ModGuts 18 | strictifyProgram guts = do 19 | newBinds <- mapM (strictifyFunc guts) (mg_binds guts) 20 | return $ guts { mg_binds = newBinds } 21 | 22 | strictifyFunc :: ModGuts -> CoreBind -> CoreM CoreBind 23 | strictifyFunc guts x@(NonRec b _) = do 24 | b' <- shouldStrictify guts b 25 | case b' of 26 | True -> everywhereM (mkM strictifyExpr) x 27 | False -> return x 28 | strictifyFunc guts x@(Rec bes) = do 29 | b <- (not . null) `liftM` (filterM (shouldStrictify guts . fst) bes) 30 | if b then everywhereM (mkM strictifyExpr) x 31 | else return x 32 | 33 | strictifyExpr :: CoreExpr -> CoreM CoreExpr 34 | strictifyExpr e@(Let (NonRec b e1) e2) 35 | | Type _ <- e1 = return e -- Yes, this can occur! 36 | | otherwise = return $ Case e1 b (exprType e2) [(DEFAULT, [], e2)] 37 | strictifyExpr e@(App e1 e2) 38 | = case e2 of 39 | App _ _ -> translate 40 | Case _ _ _ _ -> translate 41 | Cast _ _ -> translate -- May as well, these two don't 42 | Tick _ _ -> translate -- appear on types anyway 43 | _ -> return e -- N.b. don't need to consider lets since they will have been eliminated already 44 | where 45 | translate = do 46 | b <- mkSysLocalM (fsLit "strict") (exprType e2) 47 | return $ Case e2 b (exprType e) [(DEFAULT, [], App e1 (Var b))] 48 | strictifyExpr e = return e 49 | 50 | \end{code} 51 | Utilities and other miscellanious stuff 52 | \begin{code} 53 | 54 | shouldStrictify :: ModGuts -> CoreBndr -> CoreM Bool 55 | shouldStrictify guts bndr = do 56 | l <- annotationsOn guts bndr :: CoreM [Strictify] 57 | return $ not $ null l 58 | 59 | annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] 60 | annotationsOn guts bndr = do 61 | anns <- getAnnotations deserializeWithData guts 62 | return $ lookupWithDefaultUFM anns [] (varUnique bndr) 63 | 64 | \end{code} 65 | --------------------------------------------------------------------------------