timberc-1.0.1: src/Main.hs
-- The Timber compiler <timber-lang.org>
--
-- Copyright 2008 Johan Nordlander <nordland@csee.ltu.se>
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
--
-- 1. Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
--
-- 2. Redistributions in binary form must reproduce the above copyright
-- notice, this list of conditions and the following disclaimer in the
-- documentation and/or other materials provided with the distribution.
--
-- 3. Neither the names of the copyright holder and any identified
-- contributors, nor the names of their affiliations, may be used to
-- endorse or promote products derived from this software without
-- specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.
module Main where
-- Haskell98
import System(getArgs)
import List(isSuffixOf)
import qualified Monad
import qualified Char
import qualified Control.Exception as Exception ( catch, catchJust )
import System.Console.GetOpt
import qualified Directory
-- Timber Compiler
import System.FilePath
import Config
import Execution
import PP
import Common
import Parser
import qualified Syntax
import qualified Core
import Desugar1
import Rename
import Desugar2
import Depend
import Syntax2Core
import Kind
import Type
import Termred
import Type2
import Kindle
import Kindlered
import Prepare4C
import Kindle2C
import Core2Kindle
import Lambdalift
import Data.Binary
import Interfaces
import GHC.Exception
{-
Lexer:
- Checks lexical syntax and builds token stream
- Removes comments
Parser:
- Checks basic syntax and builds parse tree
- Builds constructor syntax (parsed as qualified types)
- Resolves nested infix expressions
- Converts record labels to proper selectors (with prefix .)
- Replaces prefix tuple constructors with primitive names
Desugar1:
- Checks record type acyclicity and selector consistence
- Completes dotdot record patterns and expressions with missing fields
- Translates instance declarations into instance signatures and named record terms
- Checks and resolves if/elsif/else statements
- Makes the "self" variable explicit.
- Checks validity of return statement
- Replaces prefix expression statement with dummy generator statement
- Replaces if/case statements with corresponding expressions forms
- Checks the restricted command syntax of template bodies
Rename:
- Checks for duplicate declarations and kind signatures
- Checks for duplicate selectors and constructors, and overlaps with class members
- Checks for duplicate equations and type signatures
- Checks for duplicated variables in patterns and templates
- Checks for duplication and dandling abstractions in type predicates
- Checks for unbound variables (not yet implemented -- what to do with globals?)
- Makes every type variable binding explicit in signatures and constructor declarations
- Shuffles signatures as close as possible to the corresponding definition (incl. inside patterns)
- Renames local variables using unique names
- Renames local (explicitly quantified) type variables using unique names
Desugar2:
- Checks validity of type and type scheme syntax in signatures and declarations
- Checks qualified types for syntactic ambiguity
- Removes special syntax for list, tuple and function types, as well as subtype predicates
- Captures single-variable predicates as short-hand for wildcard kind signature
- Checks syntactic validity of patterns
- Replaces after, before, [] and (:) with primitive names
- Replaces tuple expressions with primitive constructor applications
- Translates if expressions, operator sections, negations
- Collects functions defined with multiple equations while checking arities
- Flattens pattern bindings
- Removes non-trivial patterns in lambdas, assignments and generators
- Translates list expressions/patterns and list comprehensions
- Applies pattern-matching compiler to case expressions
Syntax2Core:
- Injects instance signatures among global type signatures
- Splits predicate contexts into kind environments (quantifiers) and predicates proper (qualifiers)
- Checks validity of base type syntax in declarations
- Replaces _ kinds with unique unification variable
- Replaces _ types with unique unification variable
- Applies up/down signature propagation within constructor/selector/member/signature environment
- Completes bindings and lambdas with missing signatures
- Does dependency analysis on local bindings
- Builds Core syntax tree
Kind:
- Does dependency analysis on type declarations
- Performs kind inference, replacing every kind unification variable (defaulting to *)
Decls:
- Extracts selector and constructor type schemes
- Generates global member signatures and bindings
- Replaces subtyping in type declarations with explicit coercion constructors/selectors
- Initiate subtyping graphs with reflexivity axioms (identity witness)
- Computes subtype above & below graph, closed under transitivity (checks cyclic and ambiguity errors)
- Computes instance overlap graph, closed under superclass relation (checks cyclic and ambiguity errors)
Type:
- Does dependency analysis on top-level bindings
- Performs type inference and constraint simplification/solving
- Makes all function calls match the arity of the called function
- Inserts explicit overloading and subtyping witnesses
Termred:
- Does simple term level reduction and restricted inlining within primitive environment (witnesses only)
Core2Kindle:
- Converts type expressions by making closure types explicit
- Approximates polymorphism by the wildcard type
- Splits non-trivial datatypes into constructor records with a common tag field
- Encodes monadic code by means of extra (mutable) state argument
- Sorts equations into value or function definitions, on basis of arity
- Makes fatbar and fail pattern-matching operators explicit, removes match and commit
- Implements after and before primitives in terms of Time arithmetic
-
- Replaces act and req by calls to the rts
- Builds Kindle abstract syntax
LambdaLift:
- Abstracts out free local variables from local function definitions and adds corresponding arguments to call sites
- Abstracts out free local variables from struct functions as extra value fields referenced through "this"
- Moves local function definitions to the top level
Kindle2C:
- Makes construction of cyclic data explicit
- Pretty-prints abstract syntax as C code
-}
-- | This compiles a set of Timber modules.
-- | Example: 'compile ["Main"] compiles the module in Main.t
-- | leaving the result in Main.c
-- | It also compiles every module *called* by this module
-- | right now.
compileTimber clo ifs (sm,t_file) ti_file c_file h_file
= do let Syntax.Module n is _ _ = sm
putStrLn ("[compiling "++ t_file++"]")
(imps,ifs') <- chaseIfaceFiles clo is ifs
let ((htxt,mtxt),ifc) = runM (passes imps sm)
encodeCFile ti_file ifc
writeFile c_file mtxt
writeFile h_file htxt
if api clo then do
writeAPI (rmSuffix ".ti" ti_file) ifc
return ((n,ifc):ifs')
else return ((n,ifc):ifs')
where passes imps par = do (e0,e1,e2,e3) <- initEnvs imps
(d1,a0) <- pass clo (desugar1 e0) Desugar1 par
rn <- pass clo (renameM e1) Rename d1
d2 <- pass clo desugar2 Desugar2 rn
co <- pass clo syntax2core S2C d2
kc <- pass clo (kindcheck e2) KCheck co
tc <- pass clo (typecheck e2) TCheck kc
rd <- pass clo (termred e2) Termred tc
tc2 <- pass clo (typecheck2 e2) Type2 rd
(ki,ds) <- pass clo (core2kindle e2 e3) C2K tc2
ki' <- pass clo (kindlered e3) Kindlered ki
ll <- pass clo (lambdalift e3) LLift ki'
pc <- pass clo (prepare4c e2 e3) Prepare4C ll
c <- pass clo (kindle2c (init_order imps)) K2C pc
return (c,ifaceMod a0 tc2 ds)
pass clo m p a = do -- tr ("Pass " ++ show p ++ " ...")
r <- m a
Monad.when (dumpAfter clo p)
$ tr ("#### Result after " ++ show p ++ ":\n\n" ++ render (pr r))
Monad.when (stopAfter clo p)
$ fail ("#### Terminated after " ++ show p ++ ".")
return r
makeProg clo cfg root = do txt <- readFile (root ++ ".t")
let ms@(Syntax.Module n is _ _) = runM (parser txt)
(imps,ss) <- chaseSyntaxFiles clo is [(n,ms)]
let cs = compile_order imps
is = filter nonDummy cs
let ps = map (\(n,ii) -> (snd ii,modToPath (str n)++".t")) is ++ [(ms,root++".t")]
ifs <- compileAll (clo {shortcut = True}) [] ps
r <- checkRoot clo ifs root
let basefiles = map (rmSuffix ".t" . snd) ps
c_files = map (++ ".c") basefiles
o_files = map ((++ ".o") . rmDirs) basefiles
mapM (compileC cfg clo) c_files
linkO cfg clo{outfile = root} r o_files
where nonDummy (_,(_,Syntax.Module n _ _ _)) = str n /= ""
parse clo t_file = do t_exists <- Directory.doesFileExist t_file
Monad.when (not t_exists) (fail ("File " ++ t_file ++ " does not exist."))
txt <- readFile t_file
let syntax = runM (pass clo parser Parser txt)
return (syntax,t_file)
compileAll clo ifs [] = return ifs
compileAll clo ifs (p@(ms,t_file):t_files)
= do res <- checkUpToDate clo t_file ti_file c_file h_file (impNames ms)
if res then do
putStrLn ("[skipping " ++ t_file ++ " (output is up to date)]")
compileAll clo ifs t_files
else do
ifs' <- compileTimber clo ifs (longName p) ti_file c_file h_file
compileAll clo ifs' t_files
where base = rmSuffix ".t" t_file
ti_file = base ++ ".ti"
c_file = base ++ ".c"
h_file = base ++ ".h"
qm = takeBaseName t_file
longName (Syntax.Module m a b c,t)
|reverse(takeWhile (/= '.') (reverse qm))==str m = (Syntax.Module (name0 qm) a b c,t_file)
|otherwise = errorIds "Module name not last constructor id in file name" [m]
checkUpToDate clo t_file ti_file c_file h_file imps
| shortcut clo = do ti_exists <- Directory.doesFileExist ti_file
c_exists <- Directory.doesFileExist c_file
h_exists <- Directory.doesFileExist h_file
if not ti_exists || not c_exists || not h_exists then
return False
else do
t_time <- Directory.getModificationTime t_file
ti_time <- Directory.getModificationTime ti_file
c_time <- Directory.getModificationTime c_file
h_time <- Directory.getModificationTime h_file
ti_OKs <- mapM (tiOK ti_time) imps
return (t_time < ti_time && t_time < c_time && t_time < h_time && and ti_OKs)
| otherwise = return False
where tiOK ti_time1 n = do let ti_file = modToPath (str n) ++ ".ti"
ti_exists <- Directory.doesFileExist ti_file
if (not ti_exists) then do
let lti_file = Config.libDir clo ++ "/" ++ modToPath (str n) ++ ".ti"
lti_exists <- Directory.doesFileExist lti_file
if (not lti_exists) then
internalError0 ("Cannot find interface file " ++ ti_file)
else do lti_time <- Directory.getModificationTime lti_file
return (lti_time <= ti_time1)
-- return True -- library module
else do ti_time <- Directory.getModificationTime ti_file
return (ti_time <= ti_time1)
------------------------------------------------------------------------------
main = do args <- getArgs
main2 args
-- | We have the second entry point so ghci/hugs users can call
-- | main2 directly with arguments.
main2 args = do (clo, files) <- Exception.catch (cmdLineOpts args)
fatalErrorHandler
cfg <- Exception.catch (readCfg clo)
fatalErrorHandler
let t_files = filter (".t" `isSuffixOf`) files
i_files = filter (".ti" `isSuffixOf`) files
o_files = filter (".o" `isSuffixOf`) files
badfiles = files \\ (t_files++i_files++o_files)
Monad.when (not (null badfiles)) $ do
fail ("Bad input files: " ++ showids badfiles)
mapM (listIface clo) i_files
-- Monad.when (null t_files) stopCompiler
ps <- mapM (parse clo) t_files
ifs <- compileAll clo [] ps `Exception.catch` handleError
Monad.when (stopAtC clo) stopCompiler
let root = make clo
Monad.when (root/="") (makeProg clo cfg root)
let basefiles = map (rmSuffix ".t") t_files
c_files = map (++ ".c") basefiles
mapM (compileC cfg clo) c_files
Monad.when (stopAtO clo) stopCompiler
let basenames = map rmDirs basefiles
o_files' = map (++ ".o") basenames
Monad.when(not (null basenames)) (do r <- checkRoot clo ifs (last basenames)
linkO cfg clo r (o_files ++ o_files'))
return ()
handleError (ErrorCall mess) = do
putStr ("*** Timber compilation error ***\n"++mess++"\n")
abortCompiler
checkRoot clo ifs def = do if1 <- getIFile rootMod
if2 <- getIFile rtsMod
let ts = tEnv if2
ke = Core.ksigsOf ts
ds = Core.tdefsOf ts
te = Core.tsigsOf (valEnv if1)
case lookup rootT ke of
Nothing -> fail ("Cannot locate RootType in module " ++ rtsMod)
Just Star -> case lookup rootT ds of
Nothing -> error "Internal: checkRoot"
Just (Core.DType _ t') -> checkRoot' te t'
Just _ -> checkRoot' te (Core.TId rootT)
Just _ -> fail ("Bad RootType in module " ++ rtsMod)
where rtsMod = target clo
(r,rootMod) = splitQual (root clo) def
rootN = qName rootMod (name0 r)
rootT = qName rtsMod (name0 "RootType")
checkRoot' te t0 = case [ (n,sc) | (n,sc) <- te, n == rootN ] of
[(n,sc)] -> if Core.sameType sc t0
then return n
else fail ("Incorrect root type: " ++ render (pr sc) ++ "; should be " ++ render(pr t0))
_ -> fail ("Cannot locate root " ++ (root clo) ++ " in module " ++ rootMod)
getIFile m = case lookup (name0 m) ifs of
Just ifc -> return ifc
Nothing -> do (ifc,_) <- decodeModule clo (modToPath m ++ ".ti")
return ifc
------------------------------------------------------------------------------
-- | Catch internal errors, print them and then abortCompiler.
fatalErrorHandler :: TimbercException -> IO a
fatalErrorHandler e = do putStrLn (show e)
abortCompiler
-- Getting import info ---------------------------------------------------------
chaseImps :: (String -> IO (a,String)) -> (Bool -> a -> [(Name,Bool)]) -> String -> [Syntax.Import] -> Map Name a -> IO (Map Name (ImportInfo a), Map Name a)
chaseImps readModule iNames suff imps ifs
= do bms <- mapM (readImport ifs) imps
let newpairs = [p | (p,True) <- bms]
ifs1 = [(c,ifc) | (c,(_,ifc)) <- newpairs] ++ ifs
chaseRecursively ifs1 (map fst bms) (concat [ iNames b c | ((_,(b,c)),_) <- bms ])
where readIfile ifs c = case lookup c ifs of
Just ifc -> return (ifc,False)
Nothing -> do (ifc,f) <- readModule f
return (ifc,True)
where f = modToPath(str c) ++ suff
readImport ifs (Syntax.Import b c)
= do (ifc,isNew) <- readIfile ifs c
return ((c,(b,ifc)),isNew)
chaseRecursively ifs ms []= return (ms,ifs)
chaseRecursively ifs ms (p@(r,unQual) : rs)
= case lookup r ms of
Just (b,_)
| not b && unQual -> chaseRecursively ifs (update r ms) rs -- found import chain; previously only use chain
| otherwise -> chaseRecursively ifs ms rs
Nothing -> do (ifc,isNew) <- readIfile ifs r
chaseRecursively (if isNew then (r,ifc) : ifs else ifs) ((r,(unQual,ifc)) : ms) (rs ++ iNames unQual ifc)
update r ((r',(_,ifc)) : ps)
| r == r' = (r,(True,ifc)) : ps
update r (p : ps) = p : update r ps
update _ [] = internalError0 "Main.update: did not find module"
chaseIfaceFiles clo = chaseImps (decodeModule clo) impsOf2 ".ti"
where impsOf2 b i = map (\(b',c) -> (c,b && b')) (impsOf i)
impName (Syntax.Import b c) = c
impNames (Syntax.Module _ is _ _) = map impName is
impNames2 b (Syntax.Module _ is _ _)
= map (\(Syntax.Import b' c) -> (c,b && b')) is
chaseSyntaxFiles clo = chaseImps readSyntax impNames2 ".t"
where readSyntax f = (do cont <- readFile f
let sm = runM (parser cont)
return (sm,f)) `catch` (\ e -> do let libf = Config.libDir clo ++ "/" ++ f
t_exists <- Directory.doesFileExist libf
if t_exists
then return (Syntax.Module (name0 "") [] [] [],libf)
else fail ("File "++ f ++ " does not exist."))
transImps (_,ifc) = map snd (impsOf ifc)
compile_order imps = case topSort (impNames . snd) imps of
Left ms -> errorIds "Mutually recursive modules" ms
Right is -> is
init_order imps = case topSort transImps imps of
Left ms -> errorIds "Mutually recursive modules" ms
Right is -> map fst is