Fixed a problem with GHC 6.6 and the new pass mechanism by removing all the dollars that were confusing the type-checker

backends/BackendPasses.hs

@@ -49,7 +49,7 @@ transformWaitFor :: Pass
 transformWaitFor = cOnlyPass "Transform wait for guards into wait until guards"
   []
   [Prop.waitForRemoved]
-  $ applyDepthM doAlt
+  (applyDepthM doAlt)
   where
     doAlt :: A.Process -> PassM A.Process
     doAlt a@(A.Alt m pri s)
@@ -86,7 +86,7 @@ declareSizesArray :: Pass
 declareSizesArray = occamOnlyPass "Declare array-size arrays"
   (prereq ++ [Prop.slicesSimplified, Prop.arrayConstructorsRemoved])
   [Prop.arraySizesDeclared]
-  $ applyDepthSM doStructured
+  (applyDepthSM doStructured)
   where
     defineSizesName :: Meta -> A.Name -> A.SpecType -> PassM ()
     defineSizesName m n spec
@@ -239,7 +239,7 @@ addSizesFormalParameters :: Pass
 addSizesFormalParameters = occamOnlyPass "Add array-size arrays to PROC headers"
   (prereq ++ [Prop.arraySizesDeclared])
   []
-  $ applyDepthM doSpecification
+  (applyDepthM doSpecification)
   where
     doSpecification :: A.Specification -> PassM A.Specification
     doSpecification (A.Specification m n (A.Proc m' sm args body))
@@ -276,7 +276,7 @@ addSizesActualParameters :: Pass
 addSizesActualParameters = occamOnlyPass "Add array-size arrays to PROC calls"
   (prereq ++ [Prop.arraySizesDeclared])
   []
-  $ applyDepthM doProcess
+  (applyDepthM doProcess)
   where
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.ProcCall m n params) = concatMapM transformActual params >>* A.ProcCall m n
@@ -305,7 +305,7 @@ simplifySlices :: Pass
 simplifySlices = occamOnlyPass "Simplify array slices"
   prereq
   [Prop.slicesSimplified]
-  $ applyDepthM doVariable
+  (applyDepthM doVariable)
   where
     doVariable :: A.Variable -> PassM A.Variable
     doVariable (A.SubscriptedVariable m (A.SubscriptFor m' check for) v)

frontends/OccamPasses.hs

@@ -51,7 +51,7 @@ fixConstructorTypes :: Pass
 fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"
   [Prop.constantsFolded]
   [Prop.arrayConstructorTypesDone]
-  $ applyDepthM doExpression
+  (applyDepthM doExpression)
   where
     doExpression :: A.Expression -> PassM A.Expression
     doExpression (A.ExprConstr m (A.RepConstr m' _ rep expr))
@@ -66,7 +66,7 @@ resolveAmbiguities :: Pass
 resolveAmbiguities = occamOnlyPass "Resolve ambiguities"
   [Prop.inferredTypesRecorded]
   [Prop.ambiguitiesResolved]
-  $ applyDepthM doExpressionList
+  (applyDepthM doExpressionList)
   where
     doExpressionList :: Transform A.ExpressionList
     -- A single function call inside an ExpressionList is actually a
@@ -80,7 +80,7 @@ foldConstants :: Pass
 foldConstants = occamOnlyPass "Fold constants"
   [Prop.inferredTypesRecorded]
   [Prop.constantsFolded]
-  $ applyDepthM2 doExpression doSpecification
+  (applyDepthM2 doExpression doSpecification)
   where
     -- Try to fold all expressions we encounter. Since we've recursed into the
     -- expression first, this'll also fold subexpressions of non-constant
@@ -103,7 +103,7 @@ checkConstants :: Pass
 checkConstants = occamOnlyPass "Check mandatory constants"
   [Prop.constantsFolded, Prop.arrayConstructorTypesDone]
   [Prop.constantsChecked]
-  $ applyDepthM2 doDimension doOption
+  (applyDepthM2 doDimension doOption)
   where
     -- Check array dimensions are constant.
     doDimension :: A.Dimension -> PassM A.Dimension

frontends/OccamTypes.hs

@@ -610,7 +610,7 @@ inferTypes :: Pass
 inferTypes = occamOnlyPass "Infer types"
   []
   [Prop.inferredTypesRecorded]
-  $ recurse
+  recurse
   where
     ops :: Ops
     ops = baseOp
@@ -1011,11 +1011,11 @@ checkTypes = occamOnlyPass "Check types"
   [Prop.inferredTypesRecorded, Prop.ambiguitiesResolved]
   [Prop.expressionTypesChecked, Prop.processTypesChecked,
     Prop.functionTypesChecked, Prop.retypesChecked]
-  $ checkVariables >.>
+  ( checkVariables >.>
     checkExpressions >.>
     checkSpecTypes >.>
     checkProcesses >.>
-    checkReplicators
+    checkReplicators)
 
 --{{{  checkVariables
 

frontends/RainPasses.hs

@@ -60,7 +60,7 @@ rainPasses =
 
 -- | A pass that transforms all instances of 'A.Int' into 'A.Int64'
 transformInt :: Pass
-transformInt = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] $ applyDepthM transformInt'
+transformInt = rainOnlyPass "Resolve Int -> Int64" [] [Prop.noInt] (applyDepthM transformInt')
   where
     transformInt' :: A.Type -> PassM A.Type
     transformInt' A.Int = return A.Int64
@@ -83,7 +83,7 @@ uniquifyAndResolveVars :: Pass
 uniquifyAndResolveVars = rainOnlyPass
   "Uniquify variable declarations, record declared types and resolve variable names"
   [Prop.noInt] (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded])
-  $ applyDepthSM uniquifyAndResolveVars'
+  (applyDepthSM uniquifyAndResolveVars')
   where
     uniquifyAndResolveVars' :: Data a => A.Structured a -> PassM (A.Structured a)
     
@@ -156,9 +156,9 @@ findMain :: Pass
 --Therefore this pass doesn't actually need to walk the tree, it just has to look for a process named "main"
 --in the CompState, and pull it out into csMainLocals
 findMain = rainOnlyPass "Find and tag the main function" Prop.agg_namesDone [Prop.mainTagged]
-  $    \x -> do newMainName <- makeNonce "main_"
+  (    \x -> do newMainName <- makeNonce "main_"
                 modify (findMain' newMainName)
-                applyDepthM (return . (replaceNameName "main" newMainName)) x
+                applyDepthM (return . (replaceNameName "main" newMainName)) x)
   where
     --We have to mangle the main name because otherwise it will cause problems on some backends (including C and C++)
     findMain' :: String -> CompState -> CompState
@@ -189,7 +189,7 @@ checkIntegral _ = Nothing
 transformEachRange :: Pass
 transformEachRange = rainOnlyPass "Convert seqeach/pareach loops over ranges into simple replicated SEQ/PAR"
   (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachRangeTransformed]
-  $ applyDepthSM doStructured
+  (applyDepthSM doStructured)
   where
     doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
     doStructured (A.Rep repMeta (A.ForEach eachMeta loopVar (A.ExprConstr
@@ -208,7 +208,7 @@ transformRangeRep :: Pass
 transformRangeRep = rainOnlyPass "Convert simple Rain range constructors into more general array constructors"
   (Prop.agg_typesDone ++ [Prop.eachRangeTransformed])
   [Prop.rangeTransformed]
-  $ applyDepthM doExpression
+  (applyDepthM doExpression)
   where
     doExpression :: A.Expression -> PassM A.Expression
     doExpression (A.ExprConstr _ (A.RangeConstr m t begin end))
@@ -250,7 +250,7 @@ checkFunction = return -- applyDepthM checkFunction'
 pullUpForEach :: Pass
 pullUpForEach = rainOnlyPass "Pull up foreach-expressions"
   (Prop.agg_typesDone ++ [Prop.constantsFolded]) [Prop.eachTransformed]
-  $ applyDepthSM doStructured
+  (applyDepthSM doStructured)
   where
     doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
     doStructured (A.Rep m (A.ForEach m' loopVar loopExp) s)
@@ -267,7 +267,7 @@ pullUpForEach = rainOnlyPass "Pull up foreach-expressions"
 pullUpParDeclarations :: Pass
 pullUpParDeclarations = rainOnlyPass "Pull up par declarations"
   [] [Prop.rainParDeclarationsPulledUp]
-  $ applyDepthM pullUpParDeclarations'
+  (applyDepthM pullUpParDeclarations')
   where
     pullUpParDeclarations' :: A.Process -> PassM A.Process
     pullUpParDeclarations' p@(A.Par m mode inside) 
@@ -285,7 +285,7 @@ pullUpParDeclarations = rainOnlyPass "Pull up par declarations"
 
 mobiliseLists :: Pass
 mobiliseLists = rainOnlyPass "Mobilise lists" [] [] --TODO properties
-  $ \x -> (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x
+  (\x -> (get >>= applyDepthM mobilise >>= put) >> applyDepthM mobilise x)
   where
     mobilise :: A.Type -> PassM A.Type
     mobilise t@(A.List _) = return $ A.Mobile t
@@ -293,8 +293,8 @@ mobiliseLists = rainOnlyPass "Mobilise lists" [] [] --TODO properties
 
 -- | All the items that should not occur in an AST that comes from Rain (up until it goes into the shared passes).
 excludeNonRainFeatures :: Pass
-excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] [] $
+excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] []
-  excludeConstr
+  (excludeConstr
   [ con0 A.Real32
    ,con0 A.Real64
    ,con2 A.Counted
@@ -314,5 +314,5 @@ excludeNonRainFeatures = rainOnlyPass "AST Validity check, Rain #1" [] [] $
    ,con1 A.Stop
    ,con3 A.Processor
    ,con3 A.IntrinsicProcCall
-  ]
+  ])
 

frontends/RainTypes.hs

@@ -92,7 +92,7 @@ performTypeUnification :: Pass
 performTypeUnification = rainOnlyPass "Rain Type Checking"
   ([Prop.noInt] ++ Prop.agg_namesDone)
   [Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked, Prop.retypesChecked]
-  $ \x -> do -- First, we copy the known types into the unify map:
+  (\x -> do -- First, we copy the known types into the unify map:
        st <- get
        ul <- shift $ csNames st
        put st {csUnifyPairs = [], csUnifyLookup = ul}
@@ -111,7 +111,7 @@ performTypeUnification = rainOnlyPass "Rain Type Checking"
        l <- get >>* csUnifyLookup
        ts <- mapMapM (\v -> fromTypeExp v) l
        get >>= substituteUnknownTypes ts >>= put
-       substituteUnknownTypes ts x'
+       substituteUnknownTypes ts x')
   where
     shift :: Map.Map String A.NameDef -> PassM (Map.Map UnifyIndex UnifyValue)
     shift = liftM (Map.fromList . catMaybes) . mapM shift' . Map.toList
@@ -143,7 +143,7 @@ substituteUnknownTypes mt = applyDepthM sub
 recordInfNameTypes :: Pass
 recordInfNameTypes = rainOnlyPass "Record inferred name types in dictionary"
   (Prop.agg_namesDone \\ [Prop.inferredTypesRecorded]) [Prop.inferredTypesRecorded]
-  $ checkDepthM recordInfNameTypes'
+  (checkDepthM recordInfNameTypes')
   where
     recordInfNameTypes' :: Check A.Replicator
     recordInfNameTypes' input@(A.ForEach m n e)
@@ -169,7 +169,7 @@ constantFoldPass :: Pass
 constantFoldPass = rainOnlyPass "Fold all constant expressions"
   ([Prop.noInt] ++ Prop.agg_namesDone ++ [Prop.inferredTypesRecorded])
   [Prop.constantsFolded, Prop.constantsChecked]
-  $ applyDepthM doExpression
+  (applyDepthM doExpression)
   where
     doExpression :: A.Expression -> PassM A.Expression
     doExpression = (liftM (\(x,_,_) -> x)) . constantFold

pass/Pass.hs

@@ -60,7 +60,7 @@ type PassType = (forall s. Data s => s -> PassM s)
 
 -- | A description of an AST-mangling pass.
 data Monad m => Pass_ m = Pass {
-    passCode :: forall t. Data t => t -> m t
+    passCode :: PassType
   , passName :: String
   , passPre :: Set.Set Property
   , passPost :: Set.Set Property
@@ -121,7 +121,13 @@ passOnlyOnAST name func x
                 Nothing -> dieP emptyMeta $ name ++ " crazy cast error at top-level"
                 Just y' -> return y'
 
-type PassMaker = String -> [Property] -> [Property] -> (forall t. Data t => t -> PassM t) -> Pass
+-- For all functions of this type, do NOT use dollar before the pass.
+-- That is, do not write: pass "" [] [] $ some code
+-- On GHC 6.6 (without impredicative polymorphism from 6.8.1) this
+-- will force the RHS (some code) to become monomorphic, where in fact
+-- it needs to remain polymorphic.  So just bracket the code for the
+-- pass instead, and everything will be fine
+type PassMaker = String -> [Property] -> [Property] -> PassType -> Pass
 
 passMakerHelper :: (CompState -> Bool) -> PassMaker
 passMakerHelper f name pre post code
@@ -144,14 +150,8 @@ cOnlyPass = passMakerHelper $ (== BackendC) . csBackend
 cppOnlyPass :: PassMaker
 cppOnlyPass = passMakerHelper $ (== BackendCPPCSP) . csBackend
 
-pass :: String -> [Property] -> [Property] -> (forall t. Data t => t -> PassM t) -> Pass
+pass :: PassMaker
-pass name pre post code
+pass = passMakerHelper (const True)
-  = Pass { passCode = code
-         , passName = name
-         , passPre = Set.fromList pre
-         , passPost = Set.fromList post
-         , passEnabled = const True
-         }
 
 -- | Compose a list of passes into a single pass by running them in the order given.
 runPasses :: [Pass] -> (A.AST -> PassM A.AST)

pass/PassList.hs

@@ -51,7 +51,7 @@ commonPasses opts = concat $
   [ enablePassesWhen ((== FrontendOccam) . csFrontend) simplifyTypes
   , enablePassesWhen csUsageChecking
     [pass "Usage checking" Prop.agg_namesDone [Prop.parUsageChecked]
-      $ passOnlyOnAST "usageCheckPass" $ runPassR usageCheckPass]
+      (passOnlyOnAST "usageCheckPass" $ runPassR usageCheckPass)]
   -- If usage checking is turned off, the pass list will break unless we insert this dummy item:
   , enablePassesWhen (not . csUsageChecking)
     [pass "Usage checking turned OFF" Prop.agg_namesDone [Prop.parUsageChecked]

pass/Traversal.hs

@@ -160,8 +160,8 @@ makeDescend ops@(tks, _) = gmapMFor ts recurse
     recurse = makeRecurse ops
 
 -- | Apply a transformation, recursing depth-first.
-applyDepthM :: forall m t1 s. (Monad m, Data t1, Data s) =>
+applyDepthM :: forall m t1. (Monad m, Data t1) =>
-               TransformM m t1 -> s -> m s
+               TransformM m t1 -> (forall s. Data s => s -> m s)
 applyDepthM f1 = makeRecurse ops
   where
     ops :: OpsM m

transformations/ImplicitMobility.hs

@@ -159,7 +159,7 @@ implicitMobility :: Pass
 implicitMobility 
   = rainOnlyPass "Implicit mobility optimisation"
     [] [] --TODO properties
-   $ passOnlyOnAST "implicitMobility" $ \t -> do
+   (passOnlyOnAST "implicitMobility" $ \t -> do
        g' <- buildFlowGraph labelFunctions t
               :: PassM (Either String (FlowGraph' PassM UsageLabel (), [Node],
                 [Node]))
@@ -170,5 +170,5 @@ implicitMobility
            -- data-flow analysis
            do decs <- makeMoveCopyDecisions g terms
               printMoveCopyDecisions decs
-              effectMoveCopyDecisions g decs t
+              effectMoveCopyDecisions g decs t)
 

transformations/SimplifyComms.hs

@@ -42,7 +42,7 @@ outExprs :: Pass
 outExprs = pass "Define temporary variables for outputting expressions"
   (Prop.agg_namesDone ++ Prop.agg_typesDone)
   [Prop.outExpressionRemoved]
-  $ applyDepthM doProcess
+  (applyDepthM doProcess)
   where
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Output m c ois)
@@ -137,7 +137,7 @@ transformInputCase :: Pass
 transformInputCase = pass "Transform ? CASE statements/guards into plain CASE"
   (Prop.agg_namesDone ++ Prop.agg_typesDone)
   [Prop.inputCaseRemoved]
-  $ applyDepthM doProcess
+  (applyDepthM doProcess)
   where
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Input m v (A.InputCase m' s))
@@ -184,7 +184,7 @@ transformProtocolInput :: Pass
 transformProtocolInput = pass "Flatten sequential protocol inputs into multiple inputs"
   (Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.inputCaseRemoved])
   [Prop.seqInputsFlattened]
-  $ applyDepthM2 doProcess doAlternative
+  (applyDepthM2 doProcess doAlternative)
   where
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_)))

transformations/SimplifyExprs.hs

@@ -51,7 +51,7 @@ functionsToProcs = pass "Convert FUNCTIONs to PROCs"
   (Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.parUsageChecked,
         Prop.functionTypesChecked])
   [Prop.functionsRemoved]
-  $ applyDepthM doSpecification
+  (applyDepthM doSpecification)
   where
     doSpecification :: A.Specification -> PassM A.Specification
     doSpecification (A.Specification m n (A.Function mf sm rts fs evp))
@@ -103,7 +103,7 @@ removeAfter :: Pass
 removeAfter = pass "Convert AFTER to MINUS"
   [Prop.expressionTypesChecked]
   [Prop.afterRemoved]
-  $ applyDepthM doExpression
+  (applyDepthM doExpression)
   where
     doExpression :: A.Expression -> PassM A.Expression
     doExpression (A.Dyadic m A.After a b)
@@ -122,7 +122,7 @@ expandArrayLiterals :: Pass
 expandArrayLiterals = pass "Expand array literals"
   [Prop.expressionTypesChecked, Prop.processTypesChecked]
   [Prop.arrayLiteralsExpanded]
-  $ applyDepthM doArrayElem
+  (applyDepthM doArrayElem)
   where
     doArrayElem :: A.ArrayElem -> PassM A.ArrayElem
     doArrayElem ae@(A.ArrayElemExpr e)
@@ -159,7 +159,7 @@ pullRepCounts :: Pass
 pullRepCounts = pass "Pull up replicator counts for SEQs"
   (Prop.agg_namesDone ++ Prop.agg_typesDone)
   []
-  $ applyDepthM doProcess
+  (applyDepthM doProcess)
   where
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Seq m s) = pullRepCountSeq s >>* A.Seq m
@@ -188,7 +188,7 @@ transformConstr :: Pass
 transformConstr = pass "Transform array constructors into initialisation code"
   (Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.subscriptsPulledUp])
   [Prop.arrayConstructorsRemoved]
-  $ applyDepthSM doStructured
+  (applyDepthSM doStructured)
   where
     -- For arrays, this takes a constructor expression:
     --   VAL type name IS [i = rep | expr]:

transformations/SimplifyProcs.hs

@@ -43,7 +43,7 @@ parsToProcs :: Pass
 parsToProcs = pass "Wrap PAR subprocesses in PROCs"
   [Prop.parUsageChecked]
   [Prop.parsWrapped]
-  $ applyDepthM doProcess
+  (applyDepthM doProcess)
   where
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Par m pm s)
@@ -65,7 +65,7 @@ removeParAssign :: Pass
 removeParAssign = pass "Remove parallel assignment"
   [Prop.parUsageChecked, Prop.functionsRemoved, Prop.functionCallsRemoved]
   [Prop.assignParRemoved]
-  $ applyDepthM doProcess
+  (applyDepthM doProcess)
   where
     doProcess :: A.Process -> PassM A.Process
     doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es))
@@ -82,7 +82,7 @@ flattenAssign :: Pass
 flattenAssign = pass "Flatten assignment"
   (Prop.agg_typesDone ++ [Prop.assignParRemoved])
   [Prop.assignFlattened]
-  $ makeRecurse ops
+  (makeRecurse ops)
   where
     ops :: Ops
     ops = extOpD (extOpSD baseOp ops doStructured) ops doProcess

transformations/Unnest.hs

@@ -98,7 +98,7 @@ removeFreeNames :: Pass
 removeFreeNames = pass "Convert free names to arguments"
   [Prop.mainTagged, Prop.parsWrapped, Prop.functionCallsRemoved]
   [Prop.freeNamesToArgs]
-  $ applyDepthM2 doSpecification doProcess
+  (applyDepthM2 doSpecification doProcess)
   where
     doSpecification :: A.Specification -> PassM A.Specification
     doSpecification spec = case spec of
@@ -188,11 +188,11 @@ removeNesting :: Pass
 removeNesting = pass "Pull nested definitions to top level"
   [Prop.freeNamesToArgs]
   [Prop.nestedPulled]
-  $ passOnlyOnAST "removeNesting" $ \s ->
+  (passOnlyOnAST "removeNesting" $ \s ->
        do pushPullContext
           s' <- (makeRecurse ops) s >>= applyPulled
           popPullContext
-          return $ fromJust $ cast s'
+          return $ fromJust $ cast s')
   where
     ops :: Ops
     ops = baseOp `extOpS` doStructured